home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / UTIL / Alpha 6.5.sit / Tcl / Modes / htmlEngine.tcl < prev    next >
Text File  |  1996-08-15  |  92KB  |  3,122 lines
  1. #===============================================================================
  2. #
  3. #     htmlEngine.tcl (called from html.tcl)
  4. #
  5. #    Part of HTML mode 1.2
  6. #
  7. #     General Support Routines
  8. #
  9. #     Author: Johan Linde <jl@theophys.kth.se>
  10. #
  11. #    If you make improvements to this file, please share them!
  12. #
  13. #===============================================================================
  14.  
  15. # The first two are taken from latexEngine.tcl
  16.  
  17. proc htmlIsUnsignedInteger {str1} {
  18.     return [regexp {^[0-9]+$} [string trim $str1]]
  19. }
  20.  
  21. proc htmlIsPositiveInteger {str1} {
  22.     if { [htmlIsUnsignedInteger $str1] } then {
  23.         if { ![regexp {^0+$} [string trim $str1]] } {
  24.             return 1
  25.         }
  26.     }
  27.     return 0
  28. }
  29.  
  30. proc htmlIsInteger {str} {
  31.     return [regexp {^-?[0-9]+$} [string trim $str]]
  32. }
  33.  
  34. # Checks to see if the current window is empty, except for whitespace.
  35. proc htmlIsEmptyFile {} {
  36.     return [htmlIsWhite [getText 0 [maxPos]]]
  37. }
  38.  
  39. proc htmlNotYet {} {
  40.     alertnote "Not yet, but coming soon."
  41. }
  42.  
  43. proc htmlSetCase {elem} {
  44.     global HTMLmodeVars 
  45.     set useLowerCase $HTMLmodeVars(useLowerCase)
  46.     if {$useLowerCase} { 
  47.         return [string tolower $elem] 
  48.     } else {
  49.         return [string toupper $elem] 
  50.     }
  51. }
  52.  
  53. proc htmlIsThereHomePage {} {
  54.     global homePagePath 
  55.     
  56.     if {![info exists homePagePath] || ![string length $homePagePath] || ¥
  57.     ![file exists $homePagePath]} {
  58.         alertnote "You must set your Home page folder."
  59.         if {[catch {pathProc d "Home Page folder"}] || ![info exists homePagePath] || ¥
  60.         ![string length $homePagePath] || ![file exists $homePagePath]} {
  61.             error 
  62.         }
  63.     }
  64. }
  65.  
  66. proc htmlIsThereBaseURL {msg} {
  67.     global HTMLmodeVars
  68.     if {![string length $HTMLmodeVars(baseURL)]} {
  69.         alertnote $msg
  70.         htmlServerURL
  71.         if {![string length $HTMLmodeVars(baseURL)]} {
  72.             error
  73.         }
  74.     }
  75. }
  76.  
  77. #
  78. # Mark file
  79. #
  80.  
  81. proc HTMLMarkFile {} {
  82.     set end [maxPos]
  83.     set pos 0
  84.     set l {}
  85.     set exp {<[Hh][1-6].*>[^<]*</[Hh][1-6]>}
  86.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 $exp $pos} res]} {
  87.         set start [lindex $res 0]
  88.         set end [lindex $res 1]
  89.         set text [getText $start $end]
  90.         # Remove tabs and returns from text.
  91.         regsub -all "¥[¥t¥r¥]+" $text " " text
  92.         set headtext ""
  93.         # remove all tags from text
  94.         while {1} {
  95.             set lt [string first < $text ]
  96.             if {$lt < 0} { break }
  97.             if {$lt > 0} { append headtext [string range $text 0 [expr $lt - 1]] }
  98.             set text [string range $text $lt end]
  99.             set gt [string first > $text]
  100.             if {$gt < 0} { break }
  101.             set text [string range $text [expr $gt + 1] end]
  102.         }
  103.         # Set mark only on one line.
  104.         if {$end > [nextLineStart $start]} {
  105.             set end [expr [nextLineStart $start] - 1]
  106.         }
  107.         
  108.         set indlevel [getText [expr $start + 2] [expr $start + 3]]
  109.  
  110.         if {$indlevel > 0 && $indlevel < 7} {
  111.             set lab [string range "       " 2 $indlevel]
  112.             append lab $lab $indlevel " " $headtext
  113.             # remove ;^</!( from label
  114. #             regsub -all {[;^</!(]} $lab {} lab
  115.             # Cut the menu item if it's longer than 30 letters, not to make it too long.
  116.             if {[string length $lab] > 30} {
  117.                 set lab "[string range $lab 0 29]ﾉ"
  118.             }
  119.             setNamedMark $lab $start $start $end
  120.         }
  121.  
  122.         set pos $end
  123.     }
  124.     message "Marks set."
  125. }
  126.  
  127. # Opens a file in the home page folder, if clicked on a link to a text file.
  128. # If the file doesn't exist, it can be opened in a new empty window, and automatically
  129. # saved in the right place.
  130. proc HTMLDblClick {from to} {
  131.     global htmlURLAttr homePagePath filepats
  132.     
  133.     # Build regular expressions with URL attrs.
  134.     set exp "("
  135.     foreach attr $htmlURLAttr {
  136.         append exp "$attr|"
  137.     }
  138.     set exp [string trimright $exp |]
  139.     append exp ")¥"?(¥[^ ¥¥t¥">¥]+)¥"?"
  140.  
  141.     # Check if user clicked on a link.
  142.     if {![catch {search -s -f 0 -r 1 -i 1 -m 0 $exp $from} res] && [lindex $res 1] > $from} {
  143.         # Get path to this window.
  144.         set extra [htmlThisFilePath 1]
  145.         if {[string length $extra]} {
  146.             set extraPath [lindex $extra 0]
  147.             set thisURL [string range [file dirname [lindex $extra 1]] ¥
  148.             [expr [string length $homePagePath] + 1] end]
  149.         } else {
  150.             return
  151.         }
  152.         regexp -nocase $exp [getText [lindex $res 0] [lindex $res 1]] dum1 dum2 linkTo
  153.         # Check if link begins with string from BASE to home page.
  154.         if {[string match "$extraPath*" $linkTo]} {
  155.             # Remove extraPath.
  156.             set linkTo [string range $linkTo [string length $extraPath] end]
  157.             set linkToPath [htmlPathToFile $thisURL $linkTo]
  158.         } else {
  159.             set linkToPath ""
  160.         }
  161.         # Does the file exist? Ignore it if it's outside home page folder.
  162.         # Then it point to someone else's home page.
  163.         if {[string match "$homePagePath*" $linkToPath]} {
  164.             if {[file exists $linkToPath] && ![file isdirectory $linkToPath]} {
  165.                 # Is it a text file?
  166.                 getFileInfo $linkToPath filetest
  167.                 if {$filetest(type) != "TEXT"} {
  168.                     message "[file tail $linkToPath] is not a text file."
  169.                 } else {
  170.                     edit -c $linkToPath
  171.                 }
  172.             } else {
  173.                 set isAnHtmlFile 0
  174.                 foreach suffix $filepats(HTML) {
  175.                     if {[string match $suffix $linkToPath]} {set isAnHtmlFile 1}
  176.                 }
  177.                 if {(![file exists $linkToPath] && !$isAnHtmlFile) || [file isdirectory $linkToPath]} {
  178.                     message "Cannot open [file tail $linkToPath]."
  179.                 } else {
  180.                     set htmlFile [file tail $linkToPath]
  181.                     if {[lindex [dialog -w 350 -h 140 -t "The file '$htmlFile' does not exist.¥
  182.                     Do you want to open a new empty window with this name?¥
  183.                     It will automatically be saved in the right place,¥
  184.                     and if necessary, new folders will be created."  10 10 340 100 ¥
  185.                     -b Yes 20 110 85 130 -b No 115 110 180 130] 1]} {return}
  186.                     # Create a new file and open it.
  187.                     set path [split [string range [file dirname $linkToPath] ¥
  188.                     [expr [string length $homePagePath] + 1] end] :]
  189.                     set linkToPath $homePagePath
  190.                     foreach p $path {
  191.                         append linkToPath ":$p"
  192.                         # make new folders if needed.
  193.                         if {![file exists $linkToPath]} {
  194.                             mkdir $linkToPath
  195.                         } elseif {[file exists $linkToPath] && ![file isdirectory $linkToPath]} {
  196.                             alertnote "Cannot make a new folder '[file tail $linkToPath]'.¥
  197.                             There is already a file with the same name."
  198.                             return
  199.                         }
  200.                     }
  201.                     append linkToPath ":$htmlFile"
  202.                     # create an empty file.
  203.                     set fid [open $linkToPath w]
  204.                     # I suppose it's best to close it, too.
  205.                     close $fid
  206.                     edit $linkToPath
  207.                 }
  208.             }
  209.         } else {
  210.             message "This link points outside your home page."
  211.         }
  212.     } else {
  213.         message "You must click on a URL."
  214.     }
  215. }
  216.  
  217.  
  218. # Snatch the current selection into htmlCurSel, set flag whether there is one
  219. proc htmlGetSel {{sel ""}} {
  220.     global htmlCurSel htmlIsSel
  221.     set htmlCurSel [string trim $sel]
  222.     if {![string length $htmlCurSel]} {
  223.         set htmlCurSel [string trim [getSelect]]
  224.     }
  225.     set htmlIsSel [string length $htmlCurSel]
  226. }
  227.  
  228. #
  229. # return positions of tags of including elements, as a list of 5 elements --
  230. # openstart openend closestart closeend elementname.
  231. # Elements without a closing tag are ignored.
  232. # args: point to start search backward from; point which must be enclosed
  233. #
  234. # if any problem, return just {0}
  235. #
  236. proc htmlGetContainer {curPos inclPos} {
  237.  
  238.     set startPos $curPos
  239.     set startPos2 $inclPos
  240.     set searchFinished 0
  241.     message "Searching for enclosing tagsﾉ"
  242.     while {!$searchFinished} {
  243.         # find first tag
  244.         set isStartTag 0
  245.         while {!$isStartTag} {
  246.             if {[catch {search -s -f 0 -r 1 -i 0 -m 0 {<[^<>]+>} $startPos} res] ||
  247.             [lindex $res 0] > [maxPos]} {
  248.                 message ""
  249.                 return {0}
  250.             }
  251.             set tag1start [lindex $res 0]
  252.             set tag1end   [lindex $res 1]
  253.             # get element name
  254.             if {![regexp {<([^ ¥t¥r]+).*>} [getText $tag1start $tag1end] tmp tag]} {
  255.                 message ""
  256.                 return {0}
  257.             }
  258.             # is this a closing tag?
  259.             if {[string range $tag 0 0] != "/"} { set isStartTag 1}
  260.             set startPos [expr $tag1start - 1]
  261.         }
  262.         set elem [string toupper $tag]
  263.         # find closing tag
  264.         set x </${tag}>
  265.         set sPos $tag1end
  266.         set sPos2 $tag1end
  267.         while {1} {
  268.             set res [search -s -f 1 -r 1 -i 1 -m 0 -n $x $sPos]
  269.             # Found any closing tag.
  270.             if {![llength $res]} {break}
  271.             # Look for another opening tag of the same element.
  272.             set y "<${tag}(¥[ ¥¥t¥¥r¥]+|>)"
  273.             set res2 [search -s -f 1 -r 1 -i 1 -m 0 -n $y $sPos2]
  274.             # Is it further away than the closing tag.
  275.             if {![llength $res2] || [lindex $res2 0] > [lindex $res 0]} {break}
  276.             # If not, find the next closing tag.
  277.             set sPos [lindex $res 1]
  278.             set sPos2 [lindex $res2 1]
  279.         }
  280.         
  281.         set tag2start [lindex $res 0]
  282.         set tag2end   [lindex $res 1]
  283.         # If container enclosed along with us, or there is no closing tag,
  284.         # continue searching.
  285.         if {![llength $res] || $tag2end < $inclPos} {
  286.             set startPos [expr $tag1start - 1]
  287.         } else {
  288.             set Container "$tag1start $tag1end $tag2start $tag2end" 
  289.             set searchFinished 1
  290.             set element $elem
  291.         }
  292.     }
  293.     
  294.     goto $curPos
  295.     message ""
  296.     return [concat $Container $element]
  297. }
  298.  
  299. #
  300. # return position an opening tag if the first element to the left
  301. # of startPos is an element with only an opening tag, as a list of 3 elements --
  302. # openstart openend elementname.
  303. #
  304. # if any problem, return empty string
  305. #
  306.  
  307. proc htmlGetOpening {startPos} {
  308.     
  309.     if {[catch {search -s -f 0 -r 1 -i 0 -m 0 {<[^<>]+>} $startPos} res] ||
  310.     [lindex $res 0] > [maxPos]} {
  311.         return
  312.     }
  313.     set tag1start [lindex $res 0]
  314.     set tag1end   [lindex $res 1]
  315.     # get element name
  316.     if {![regexp {<([^ ¥t¥r]+).*>} [getText $tag1start $tag1end] tmp tag]} {
  317.         return
  318.     }
  319.     # is this a closing tag?
  320.     if {[string range $tag 0 0] == "/"} {return}
  321.     
  322.     # find closing tag
  323.     set x </${tag}>
  324.     set sPos $tag1end
  325.     set sPos2 $tag1end
  326.     while {1} {
  327.         set res [search -s -f 1 -r 1 -i 1 -m 0 -n $x $sPos]
  328.         # Found any closing tag.
  329.         if {![llength $res]} {break}
  330.         # Look for another opening tag of the same element.
  331.         set y "<${tag}(¥[ ¥¥t¥¥r¥]+|>)"
  332.         set res2 [search -s -f 1 -r 1 -i 1 -m 0 -n $y $sPos2]
  333.         # Is it further away than the closing tag.
  334.         if {![llength $res2] || [lindex $res2 0] > [lindex $res 0]} {break}
  335.         # If not, find the next closing tag.
  336.         set sPos [lindex $res 1]
  337.         set sPos2 [lindex $res2 1]
  338.     }
  339.     
  340.     if {![llength $res] } {
  341.         return "$tag1start $tag1end [string toupper $tag]"
  342.     } else {
  343.         return
  344.     }
  345.     
  346. }
  347.  
  348. # Asks for a file and returns the file name including the relative path from
  349. # current window, provided both are in the home page folder. Otherwise an empty 
  350. # string is returned.
  351. proc htmlGetFile {} {
  352.     global HTMLmodeVars homePagePath 
  353.         
  354.     # get path to this window.
  355.     set this [htmlThisFilePath 0]
  356.     if {[string length $this]} {
  357.         set extraPath [lindex $this 0]
  358.         set thisFile [lindex $this 1]
  359.     } else {
  360.         return
  361.     }
  362.     
  363.     # Get the file to link to.
  364.     if {[catch {getfile "Select file to link to."} linkFile]} {
  365.         return 
  366.     }
  367.     # Is this file in home page folder?
  368.     if {![string match ${homePagePath}* $linkFile]} {
  369.         alertnote "'[file tail $linkFile]' is not in the home page folder. In this way you can only¥
  370.         make links to files in the home page folder."
  371.         return 
  372.     }
  373.     set linkTo "$extraPath[htmlRelativePath $thisFile $linkFile]"
  374.     # Add URL to cache.
  375.     htmlAddToCache URLs $linkTo
  376.     return $linkTo
  377. }
  378.  
  379. # Returns the path to the current window, with corrections if BASE is used.
  380. # Returns path from BASE to home page.
  381. # If the current window is not in the home page folder an empty sring is returned.
  382. # Called with 0 if called from htmlGetFile.
  383. # Called with 1 if called from HTMLDblClick. (0 or 1 determines the error message.)
  384. proc htmlThisFilePath {errorMsg} {
  385.     global homePagePath
  386.     
  387.     # Check that homePagePath is set.
  388.     if {[catch htmlIsThereHomePage]} {return}
  389.     
  390.     # Remove ending :, otherwise glob will get confused, as well as other parts of the code. 
  391.     set homePagePath [string trimright $homePagePath :]
  392.     
  393.     set thisFile [lindex [winNames -f] 0]
  394.     # Strip off trailing garbage (if any)
  395.     regexp {(.*) <[0-9]+>} $thisFile dummy thisFile
  396.  
  397.     set extraPath ""
  398.     
  399.     # Look for BASE element.
  400.     if {![catch {search -s -f 1 -r 1 -i 1 -m 0 {<BASE[^>]*>} 0} res] && ¥
  401.     [regexp {[hH][rR][eE][fF]=¥"?([^ ¥t¥r¥">]+)} [getText [lindex $res 0] ¥
  402.     [lindex $res 1]] dum href]} {
  403.         set extra [htmlPathFromBASE $href]
  404.         if {![string length $extra]} {return}
  405.         set extraPath [lindex $extra 0]
  406.         set thisFile [lindex $extra 1]
  407.     } else {
  408.         # Check if window is saved.
  409.         if {![file exists $thisFile]} {
  410.             if {$errorMsg} {
  411.                 set etxt "You must save the window, otherwise it cannot be determined¥
  412.                 where the link is pointing."
  413.             } else {
  414.                 set etxt "You must save the window. If you save, you will then be prompted¥
  415.                 for a file to link to."
  416.             }
  417.             if {[lindex [dialog -w 400 -h 100 -t $etxt 10 10 390 60  ¥
  418.             -b Save 20 70  85 90 ¥
  419.             -b Cancel 110 70 175 90] 1]} {
  420.                 return
  421.             }
  422.             
  423.             if {![catch {saveAs [lindex [winNames] 0]}]} {
  424.                 set thisFile [lindex [winNames -f] 0]
  425.                 regexp {(.*) <[0-9]+>} $thisFile dummy thisFile
  426.             } else {
  427.                 return 
  428.             }
  429.         }
  430.         # Is window in home page folder?
  431.         if {![string match ${homePagePath}* $thisFile]} {
  432.             if {$errorMsg} {
  433.                 message "Window not in home page folder. Cannot determine where the link is pointing."
  434.             } else {
  435.                 alertnote "Current window is not in the home page folder. In this way you can only¥
  436.                 make links between files in the home page folder."
  437.             }
  438.             return 
  439.         }
  440.     }
  441.     return [list $extraPath $thisFile]
  442. }
  443.  
  444.  
  445. proc htmlPathFromBASE {href} {
  446.     global HTMLmodeVars homePagePath
  447.     
  448.     # When BASE is used, Server URL must be set.
  449.     if {[catch {htmlIsThereBaseURL "You must set the Server URL when you use the BASE element."}]} {
  450.         return
  451.     }
  452.     
  453.     set baseURL $HTMLmodeVars(baseURL)
  454.     set basePath $HTMLmodeVars(basePath)
  455.     
  456.     set extraPath ""
  457.     set thisFile $homePagePath
  458.     # If BASE is somewhere else, make an absolute link.
  459.     if {![string match "${baseURL}*" $href]} {
  460.         set extraPath "$baseURL$basePath"
  461.         append thisFile ":dummy"
  462.     } elseif {[string match "$baseURL$basePath*" $href]} {
  463.         # BASE point to Home page.
  464.         set bPath [split [string range $href [string length "$baseURL$basePath"] end] /]
  465.         foreach b $bPath {
  466.             append thisFile ":" $b
  467.         }
  468.         # If bPath is empty we must add a dummy file.
  469.         if {$thisFile == $homePagePath} {append thisFile ":dummy"}
  470.     } else {
  471.         # Find path from BASE to Home page.
  472.         set thisBase [split [string range $href [string length $baseURL] end] /]
  473.         set thisBase [lrange $thisBase 0 [expr [llength $thisBase] - 2]]
  474.         set bPath [split [string trimright $basePath /] /]
  475.         set i 0
  476.         while {[llength $thisBase] > $i && [llength $bPath] > $i ¥
  477.         && [lindex $thisBase $i] == [lindex $bPath $i]} {
  478.             incr i
  479.         }
  480.         set thisBase [lrange $thisBase $i end]
  481.         set bPath [lrange $bPath $i end]
  482.         foreach t $thisBase {
  483.             append extraPath "../"
  484.         }
  485.         foreach b $bPath {
  486.             append extraPath "$b/"
  487.         }
  488.         append thisFile ":dummy"
  489.     }
  490.     return [list $extraPath $thisFile]
  491. }
  492.  
  493. # Returns toFile including relative path from fromFile.
  494.  
  495. proc htmlRelativePath {fromFile toFile} {
  496.     set fromdir [split [file dirname $fromFile] :]
  497.     set todir [split [file dirname $toFile] :]
  498.     
  499.     # Remove the common path.
  500.     set i 0
  501.     while {[llength $fromdir] > $i && [llength $todir] > $i ¥
  502.     && [lindex $fromdir $i] == [lindex $todir $i]} {
  503.         incr i
  504.     }
  505.  
  506.     set fromdir [lrange $fromdir $i end]
  507.     set todir [lrange $todir $i end]
  508.  
  509.     # Insert ../
  510.     foreach f $fromdir {
  511.         append linkTo "../"
  512.     }
  513.     # Add the path.
  514.     foreach f $todir {
  515.         append linkTo "$f/"
  516.     }
  517.     # Add file name
  518.     append linkTo [file tail $toFile]
  519.     
  520.     return $linkTo
  521. }
  522.  
  523. # Check that links are valid.
  524. proc htmlCheckLinks {where} {
  525.     global homePagePath HTMLmodeVars
  526.     
  527.     # Check that homePagePath is set.
  528.     if {[catch htmlIsThereHomePage]} {return}
  529.     
  530.     # Remove ending :, otherwise it will all be a mess.
  531.     set homePagePath [string trimright $homePagePath :]
  532.     # Check that the server URL is set.
  533.     if {[catch {htmlIsThereBaseURL "You must set the Server URL."}]} {return}
  534.     
  535.     # Save all open window?
  536.     set savewin [askyesno -c "Save all open windows before checking links?"]
  537.     if {$savewin == "cancel"} {
  538.         return
  539.     } elseif {$savewin == "yes"} {saveAll}
  540.         
  541.     if {$where == "file"} {
  542.         if {[catch {getfile "Select file to scan."} files]} {return}
  543.         # Is this a text file?
  544.         getFileInfo $files filetest
  545.         if {$filetest(type) != "TEXT"} {
  546.             alertnote "'[file tail $files]' is not a text file."
  547.             return
  548.         }
  549.         # Is this file in home page folder?
  550.         if {![string match ${homePagePath}* $files]} {
  551.             alertnote "'[file tail $files]' is not in the home page folder."
  552.             return
  553.         }
  554.         # Make it a list in case it contains spaces.
  555.         set files [list $files]
  556.     } elseif {$where == "folder"} {
  557.         if {[catch {get_directory -p "Folder to scan."} folder]} {return}
  558.         set folder [string trimright $folder :]
  559.         # Is this folder in home page folder?
  560.         if {![string match ${homePagePath}* $folder]} {
  561.             alertnote "'[file tail $folder]' is not in the home page folder."
  562.             return
  563.         }
  564.         set files [htmlGetHTMLfiles $folder]
  565.     } else {
  566.         set files [htmlAllHTMLfiles]
  567.     }
  568.     htmlScanFiles $files 1
  569. }
  570.  
  571. # Returns a list of all HTML files in home page folder.
  572. proc htmlAllHTMLfiles {} {
  573.     global homePagePath
  574.     message "Building file listﾉ"
  575.     set folders [list $homePagePath]
  576.     while {[llength $folders]} {
  577.         set newFolders ""
  578.         foreach fl $folders { 
  579.             append files " " [htmlGetHTMLfiles $fl]
  580.             # Get folders in this folder.
  581.             if {![catch {glob "$fl:*"} filelist]} {
  582.                 foreach fil $filelist {
  583.                     if {[file isdirectory $fil]} {
  584.                         lappend newFolders $fil
  585.                     }
  586.                 }
  587.             }
  588.         }
  589.         set folders $newFolders
  590.     }
  591.     return $files
  592. }
  593.  
  594. # Finds all HTML files in a folder
  595. proc htmlGetHTMLfiles {folder} {
  596.     global filepats
  597.     set files ""
  598.     if {![catch {glob -t TEXT $folder:*} filelist]} {
  599.         foreach fil $filelist {
  600.             foreach suffix $filepats(HTML) {
  601.                 if {[string match $suffix $fil]} {
  602.                     lappend files $fil
  603.                     break
  604.                 }
  605.             }
  606.         }
  607.     }
  608.     return $files
  609. }
  610.  
  611.  
  612. # checking = 1: called from htmlCheckLinks
  613. # Scan a list of files for HTML links and check if they point to existing files.
  614. # Some code is taken from grep.tcl
  615. # checking = 0: called from htmlMoveFiles
  616. # Build a list of links which point to the files just moved.
  617. proc htmlScanFiles {files checking {movedFiles ""}} {
  618.     global htmlURLAttr homePagePath winModes
  619.     global tileLeft tileTop tileWidth errorHeight
  620.     
  621.     # Build regular expressions with URL attrs.
  622.     set exp "¥[ ¥¥t¥¥n¥¥r¥]+("
  623.     foreach attr $htmlURLAttr {
  624.         append exp "$attr|"
  625.     }
  626.     set exp [string trimright $exp |]
  627.     append exp ")"
  628.  
  629.     
  630.     set expBase "<base¥[ ¥¥t¥¥n¥¥r¥]+¥[^>¥]*>"
  631.     set expBase2 "(href=)¥"?(¥[^ ¥¥t¥¥n¥¥r¥">¥]+)¥"?"
  632.     set exprr "$exp¥"?(¥[^ ¥¥t¥¥n¥¥r¥">¥]+)¥"?"
  633.     
  634.     set lines ""
  635.  
  636.     foreach f $files {
  637.         if {![catch {set fid [open $f]}]} {
  638.             set extraPath ""
  639.             set baseText ""
  640.             set thisURL [string range [file dirname $f] ¥
  641.             [expr [string length $homePagePath] + 1] end]
  642.             message "Looking at [file tail $f]ﾉ"
  643.             set filecont [read $fid]
  644.             close $fid
  645.             if {[regexp {¥n} $filecont]} {
  646.                 set newln "¥n"
  647.             } else {
  648.                 set newln "¥r"
  649.             }
  650.             # Look for BASE.
  651.             if {[regexp -nocase $expBase $filecont thisLine]} {
  652.                 if {[regexp -nocase $expBase2 $thisLine href b url]} {
  653.                     set extra [htmlPathFromBASE $url]
  654.                     set extraPath [lindex $extra 0]
  655.                     set thisURL [string range [file dirname [lindex $extra 1]] ¥
  656.                     [expr [string length $homePagePath] + 1] end]
  657.                     set baseText "(BASE used) "
  658.                 }
  659.             }
  660.             set linenum 1
  661.             # Find all links in every line.
  662.             while {[regexp -nocase -indices $exprr $filecont href b url]} {
  663.                 incr linenum [regsub -all $newln [string range $filecont 0 [lindex $url 0]] {} dummy]
  664.                 set l [expr 20 - [string length [file tail $f]]]
  665.                 set ln [expr 5 - [string length $linenum]]
  666.                 set href [string trim [string range $filecont [lindex $href 0] [lindex $href 1]]]
  667.                 set linkTo [string range $filecont [lindex $url 0] [lindex $url 1]]
  668.                 # Check if link begins with string from BASE to home page, or is absolute.
  669.                 if {[string match "$extraPath*" $linkTo] || [regexp {://} $linkTo]} {
  670.                     # Remove extraPath if link is not absolute.
  671.                     if {![regexp {://} $linkTo]} {
  672.                         set linkTo [string range $linkTo [string length $extraPath] end]
  673.                     }
  674.                     set linkToPath [htmlPathToFile $thisURL $linkTo]
  675.                     # If this is BASE HREF, ignore it.
  676.                     if {[string length $baseText] && [regexp -nocase -indices $expBase $filecont thisLine] ¥
  677.                     && [regexp -nocase $expBase2 [string range $filecont [lindex $thisLine 0] [lindex $thisLine 1]]]¥
  678.                     && [lindex $thisLine 0] < [lindex $url 0] && [lindex $thisLine 1] > [lindex $url 1]} {
  679.                         set linkToPath ""
  680.                     }
  681.                 } else {
  682.                     set linkToPath ""
  683.                 }
  684.                 set filecont [string range $filecont [lindex $url 1] end]
  685.                 if {$checking} {
  686.                     # Does the file exist? Ignore it if it's outside home page folder.
  687.                     # Then it point to someone else's home page.
  688.                     if {[string match "$homePagePath*" $linkToPath] && ![file exists $linkToPath]} {
  689.                         append lines "[string range $f [expr [string length $homePagePath] + 1] end]"¥
  690.                         "[format "%$l¥s" ""]; Line $linenum:[format "%$ln¥s" ""]$baseText$href"¥
  691.                         "¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥t¥tｰ$f¥r"
  692.                     }
  693.                 } else {
  694.                     if {[lsearch -exact $movedFiles $linkToPath] >=0 } {
  695.                         if {[string length $thisURL]} {
  696.                             set dum ":dummy"
  697.                         } else {
  698.                             set dum dummy
  699.                         }
  700.                         lappend toModify [list $f $linenum $extraPath "$homePagePath:${thisURL}$dum" $linkToPath $href]
  701.                     }
  702.                 }
  703.             }
  704.         }
  705.     }
  706.  
  707.     if {$checking} {
  708.         if {[string length $lines]} {
  709.             new -n "* Invalid URLs *" -g $tileLeft $tileTop $tileWidth $errorHeight
  710.             set name [lindex [winNames] 0]
  711.             changeMode [set winModes($name) Brws]
  712.             insertText "Links to non-existing files:  (<cr> to go to file)¥r¥r"
  713.             insertText $lines
  714.             select [nextLineStart [nextLineStart 0]] [nextLineStart [nextLineStart [nextLineStart 0]]]
  715.             setWinInfo dirty 0
  716.             setWinInfo read-only 1        
  717.         } else {
  718.             alertnote "All links are OK."
  719.         }
  720.     } else {
  721.         if {[info exists toModify]} {
  722.             return $toModify
  723.         } else {
  724.             return ""
  725.         }
  726.     }
  727. }
  728.  
  729. # Determine the path to the file "to", as linked from "from". Returns empty string if
  730. # "to" is a link outside the home page.
  731. proc htmlPathToFile {from to} {
  732.     global homePagePath HTMLmodeVars
  733.     
  734.     set baseURL $HTMLmodeVars(baseURL)
  735.     set basePath $HTMLmodeVars(basePath)
  736.     
  737.     # Remove anchor from "to".
  738.     regexp {[^#]*} $to to
  739.     
  740.     # Remove ./ from path
  741.     if {[string range $to 0 1] == "./"} {set to [string range $to 2 end]}
  742.     
  743.     # Relative URL beginning with / is relative to server URL.
  744.     if {[string range $to 0 0] == "/"} {
  745.         set to "$baseURL[string range $to 1 end]"
  746.     }
  747.     
  748.     # Is this a absolute URL somewhere else or a mailto URL?
  749.     if {([regexp {://} $to] && ![string match "$baseURL$basePath*" $to]) ¥
  750.     || [string match "mailto:*" [string tolower $to]]} {
  751.         return
  752.     }
  753.  
  754.     # Absolut URL within the home page?
  755.     if {[string match "$baseURL$basePath*" $to]} {
  756.         set to [string range $to [expr [string length $baseURL] + ¥
  757.         [string length $basePath]] end]
  758.         set from ""
  759.     }
  760.     set fromPath [split $from :]
  761.     set toPath [split $to /]
  762.     
  763.     # Back down for every ../
  764.     foreach tp $toPath {
  765.         if {$tp == ".."} {
  766.             if {[llength $fromPath]} {
  767.                 set fromPath [lrange $fromPath 0 [expr [llength $fromPath] - 2]]
  768.                 set toPath [lrange $toPath 1 end]
  769.             } else {
  770.                 # this link points outside the home page.
  771.                 return
  772.             }
  773.         } else {
  774.             break
  775.         }
  776.     }
  777.     set path ""
  778.     # Add path to file linked from.
  779.     if {[llength $fromPath]} {append path "[join $fromPath :]:"}
  780.     # Add path to file linked to.
  781.     append path [join $toPath :]
  782.     set path [string trimright $path :]
  783.     # If link to folder, add index.html.
  784.     if {[file isdirectory "${homePagePath}:$path"]} {
  785.         if {[string length $path]} {append path :}
  786.         append path "index.html"
  787.     }
  788.     return "${homePagePath}:$path"
  789. }    
  790.  
  791. # Moves files from one folder to another and update all links to the moved files
  792. # as well as all links in the moved files.
  793. proc htmlMoveFiles {} {
  794.     global homePagePath HTMLmodeVars htmlURLAttr
  795.     
  796.     # Check that homePagePath is set.
  797.     if {[catch htmlIsThereHomePage]} {return}
  798.     # Remove ending :, otherwise it will all be a mess.
  799.     set homePagePath [string trimright $homePagePath :]
  800.     # Check that the server URL is set.
  801.     if {[catch {htmlIsThereBaseURL "You must set the Server URL."}]} {return}
  802.     
  803.     set baseURL $HTMLmodeVars(baseURL)
  804.     set basePath $HTMLmodeVars(basePath)
  805.     
  806.     if {[askyesno "All windows must be saved before you can moves files. Save?"] == "no"} {return}
  807.     saveAll
  808.     # Get folder to move from.
  809.     if {[catch {get_directory -p "Move from."} fromFolder]} {return}
  810.     set fromFolder [string trimright $fromFolder :]
  811.     # Is this folder in home page folder?
  812.     if {![string match ${homePagePath}* $fromFolder]} {
  813.         alertnote "'[file tail $fromFolder]' is not in the home page folder."
  814.         return
  815.     }
  816.     
  817.     # Get files to move.
  818.     if {![catch {glob "$fromFolder:*"} files]} {
  819.         foreach f $files {
  820.             if {![file isdirectory $f]} {
  821.                 lappend filelist [file tail $f]
  822.             }
  823.         }
  824.     } else {
  825.         return
  826.     }
  827.     
  828.     if {[catch {listpick -p "Select files to move." -l $filelist} movefiles] || ¥
  829.     ![string length $movefiles]} {return}
  830.     
  831.     # Get folder to move to.
  832.     if {[catch {get_directory -p "Move to."} toFolder]} {return}
  833.     set toFolder [string trimright $toFolder :]
  834.     if {$fromFolder == $toFolder} {
  835.         alertnote "This is the same folder as you moved from."
  836.         return
  837.     }
  838.     # Is this folder in home page folder?
  839.     if {![string match ${homePagePath}* $toFolder]} {
  840.         alertnote "'[file tail $toFolder]' is not in the home page folder."
  841.         return
  842.     }
  843.     
  844.     # Move the files.
  845.     foreach f $movefiles {
  846.         if {[file exists "$toFolder:$f"]} {
  847.             if {[askyesno "Replace '$f' in folder '[file tail $toFolder]'?"] == "yes"} {
  848.                 removeFile "$toFolder:$f"
  849.             } else {
  850.                 continue
  851.             }
  852.         }
  853.         foreach w [winNames -f] {
  854.             set ww $w
  855.             regexp {(.*) <[0-9]+>} $w dummy w
  856.             if {$w == "$fromFolder:$f"} {
  857.                 alertnote "'[file tail $ww]' must be closed before it can be moved. It will be reopened again."
  858.                 bringToFront $ww
  859.                 killWindow
  860.                 lappend reOpen "$toFolder:$f"
  861.             }
  862.         }
  863.         lappend movedFiles "$fromFolder:$f"
  864.         lappend movedFiles2 "$toFolder:$f"
  865.         mv "$fromFolder:$f" "$toFolder:$f"
  866.     }
  867.     
  868.     if {![info exists movedFiles] || [askyesno "Files have been moved. Update links?"] == "no"} {return}
  869.     
  870.     set allfiles [htmlAllHTMLfiles]
  871.     foreach f $movedFiles2 {
  872.         if {[set i [lsearch -exact $allfiles $f]] >= 0} {
  873.             set allfiles [lreplace $allfiles $i $i]
  874.         }
  875.     }
  876.     
  877.     # Build regular expressions with URL attrs.
  878.     set exp "("
  879.     foreach attr $htmlURLAttr {
  880.         append exp "$attr|"
  881.     }
  882.     set exp [string trimright $exp |]
  883.     append exp ")"
  884.  
  885.     
  886.     set expBase "<(base¥[ ¥¥t¥¥n¥¥r¥]+)¥[^>¥]*>"
  887.     set expBase2 "(href=)¥"?(¥[^ ¥¥t¥¥n¥¥r¥">¥]+)¥"?"
  888.     set exprr "$exp¥"?(¥[^ ¥¥t¥¥n¥¥r¥">¥]+)¥"?"
  889.     set exprr2 "¥[ ¥¥t¥¥n¥¥r¥]+$exp¥"?(¥[^ ¥¥t¥¥n¥¥r¥">¥]+)¥"?"
  890.  
  891.     # Update links to the moved files.
  892.     set toModify [htmlScanFiles $allfiles 0 $movedFiles]
  893.  
  894.     set num 0
  895.     if {[llength $toModify]} {
  896.         set thisfile ""
  897.         foreach modify $toModify {
  898.             set fil [lindex $modify 0]
  899.             if {$thisfile != $fil} {
  900.                 if {[string length $thisfile]} {
  901.                     set fid [open $thisfile w]
  902.                     puts -nonewline $fid [join $filecont "¥r"]
  903.                     close $fid
  904.                 }
  905.                 message "Modifying [file tail $fil]ﾉ"
  906.                 foreach w [winNames -f] {
  907.                     set ww $w
  908.                     regexp {(.*) <[0-9]+>} $w dummy w
  909.                     if {$w == "$fil"} {
  910.                         lappend changed $ww
  911.                     }
  912.                 }
  913.                 set fid [open $fil r]
  914.                 incr num
  915.                 set filec [read $fid]
  916.                 close $fid
  917.                 if {[regexp {¥n} $filec]} {
  918.                     set newln "¥n"
  919.                 } else {
  920.                     set newln "¥r"
  921.                 }
  922.                 set filec [split $filec $newln]
  923.                 set filecont ""
  924.                 foreach fc $filec {
  925.                     lappend filecont [string trimleft $fc "¥r"]
  926.                 }
  927.             }
  928.             set thisfile $fil
  929.             set linenum [expr [lindex $modify 1] - 1]
  930.             set line [lindex $filecont $linenum]
  931.             set path [lindex $movedFiles2 [lsearch -exact $movedFiles [lindex $modify 4]]]
  932.             set linkTo "[lindex $modify 2][htmlRelativePath [lindex $modify 3] $path]"
  933.             regexp -indices [lindex $modify 5] $line href
  934.             regexp -nocase -indices $exprr [string range $line [lindex $href 0] [lindex $href 1]] a b url
  935.             set anchor ""
  936.             regexp {[^#]*(#[^¥"]*)} [lindex $modify 5] a anchor
  937.             set line "[string range $line 0 [expr [lindex $href 0] + [lindex $url 0] - 1]]$linkTo$anchor[string range $line [expr [lindex $href 0] + [lindex $url 1] + 1] end]"
  938.             set filecont [lreplace $filecont $linenum $linenum $line]
  939.         }
  940.         set fid [open $thisfile w]
  941.         puts -nonewline $fid [join $filecont "¥r"]
  942.         close $fid
  943.     }
  944.     
  945.     # Modify links in moved files.
  946.     foreach f $movedFiles2 {
  947.         getFileInfo $f finfo
  948.         if {$finfo(type) != "TEXT"} {continue}
  949.         message "Modifying [file tail $f]ﾉ"
  950.         set fid [open $f r]
  951.         set filecont [read $fid]
  952.         close $fid
  953.         set oldfile [lindex $movedFiles [lsearch -exact $movedFiles2 $f]]
  954.         # Replace newline chars in IBM files.
  955.         regsub -all "¥[¥r¥n¥]+" $filecont "¥r" filecont
  956.         # If BASE is used, only modify links to moved files.
  957.         if {[regexp -nocase $expBase $filecont this] && ¥
  958.         [regexp -nocase $expBase2 $this d1 d2 url1]} {
  959.             set hasBase 1
  960.         } else {
  961.             set hasBase 0
  962.         }
  963.         set f0 $f
  964.         if {$hasBase} {
  965.             set extra [htmlPathFromBASE $url1]
  966.             set extraPath [lindex $extra 0]
  967.             set oldfile "[file dirname [lindex $extra 1]]:[file tail $oldfile]"
  968.             set f $oldfile
  969.         } else {
  970.             set extraPath ""
  971.         }
  972.         incr num
  973.         set newcont ""
  974.         while {[regexp -nocase -indices $exprr2 $filecont href b url]} {
  975.             set urltxt [string range $filecont [lindex $url 0] [lindex $url 1]]
  976.             set anchor ""
  977.             regexp {[^#]*(#[^¥"]*)} $urltxt a anchor
  978.             if {[string match "$extraPath*" $urltxt] || [regexp {://} $urltxt]} {
  979.                 if {![regexp {://} $urltxt]} {
  980.                     set urltxt [string range $urltxt [string length $extraPath] end]
  981.                 }
  982.                 set path [htmlPathToFile [string range [file dirname $oldfile] ¥
  983.                 [expr [string length $homePagePath] + 1] end] $urltxt]
  984.                 # Is the link pointing to a previously moved file?
  985.                 if {[set mvind [lsearch -exact $movedFiles $path]] >= 0} {
  986.                     set path [lindex $movedFiles2 $mvind]
  987.                 }
  988.                 if {$hasBase && [regexp -nocase -indices $expBase $filecont thisLine] ¥
  989.                 && [regexp -nocase $expBase2 [string range $filecont [lindex $thisLine 0] [lindex $thisLine 1]]]¥
  990.                 && [lindex $thisLine 0] < [lindex $url 0] && [lindex $thisLine 1] > [lindex $url 1]} {
  991.                     set path ""
  992.                 }
  993.             } else {
  994.                 set path ""
  995.             }
  996.             if {[string length $path]} {
  997.                 set newurl "$extraPath[htmlRelativePath $f $path]$anchor"
  998.             } elseif {!$hasBase && ($urltxt == ".." || [string range $urltxt 0 2] == "../")} {
  999.                 # Special case with relative links outside home page.
  1000.                 set urlspl [split $urltxt /]
  1001.                 set old [split $oldfile :]
  1002.                 set new [split $f :]
  1003.                 if {[llength $new] > [llength $old]} {
  1004.                     set newurl ""
  1005.                     for {set i 0} {$i < [expr [llength $new] - [llength $old]]} {incr i} {
  1006.                         append newurl "../"
  1007.                     }
  1008.                     append newurl $urltxt
  1009.                 } else {
  1010.                     set ok 1
  1011.                     for {set i 0} {$i < [expr [llength $old] - [llength $new]]} {incr i} {
  1012.                         if {[lindex $urlspl $i] != ".."} {set ok 0}
  1013.                     }
  1014.                     if {$ok} {
  1015.                         set newurl "[join [lrange $urlspl [expr [llength $old] - [llength $new]] end] /]$anchor"
  1016.                     } else {
  1017.                         set newurl $urltxt
  1018.                     }
  1019.                 }
  1020.             } else {
  1021.                 set newurl $urltxt
  1022.             }
  1023.             append newcont [string range $filecont 0 [expr [lindex $url 0] - 1]]
  1024.             append newcont $newurl
  1025.             set filecont [string range $filecont [expr [lindex $url 1] + 1] end]
  1026.         }
  1027.         append newcont $filecont
  1028.         set fid [open $f0 w]
  1029.         puts -nonewline $fid $newcont
  1030.         close $fid
  1031.     }
  1032.     message "$num files has been modified including the ones moved."
  1033.  
  1034.     if {[info exists reOpen] && [askyesno "Reopen previously closed windows?"] == "yes"} {
  1035.         foreach r $reOpen {
  1036.             edit $r
  1037.         }
  1038.     }
  1039.     
  1040.     if {[info exists changed] && [askyesno "Revert modified windows?"] == "yes"} {
  1041.         foreach r $changed {
  1042.             bringToFront $r
  1043.             revert
  1044.         }
  1045.     }
  1046. }
  1047.  
  1048.     
  1049. #
  1050. # dividing line
  1051. #
  1052. proc htmlDividingLine {} {
  1053.     global HTMLmodeVars fillColumn
  1054.     set wordWrap    $HTMLmodeVars(wordWrap)
  1055.     set prefixString    $HTMLmodeVars(prefixString)
  1056.     set suffixString    $HTMLmodeVars(suffixString)
  1057.  
  1058.     set s "===================================================================================="
  1059.     set l [expr [string length $prefixString] + [string length $suffixString]]
  1060.     if {$wordWrap} { 
  1061.         set l [expr $fillColumn - $l - 1] 
  1062.     } else {
  1063.         set l [expr 75 - $l - 1]
  1064.     }
  1065.     insertText [htmlOpenCR] $prefixString [string range $s 0 $l] $suffixString "¥r"
  1066. }
  1067.  
  1068.  
  1069. #
  1070. # Carriage returns and tabs (much borrowed from latex.tcl)
  1071. #
  1072.  
  1073. # A boolean function which takes any string and tests to see if
  1074. # that string contains all whitespace characters.  Carriage returns 
  1075. # are considered whitespace, as are spaces and tabs.
  1076. proc htmlIsWhite {anyString} {
  1077.     set len [string length $anyString]
  1078.     for {set i 0} {$i < $len} {incr i} {
  1079.         set c [string index $anyString $i]
  1080.         if {($c != "¥ ") && ($c != "¥t") && ($c != "¥r")} then {return 0}
  1081.     }
  1082.     return 1
  1083. }
  1084.  
  1085. # Insert one or two carriage returns at the insertion point if any
  1086. # character preceding the insertion point (on the same line)
  1087. # is a non-whitespace character.
  1088. proc htmlOpenCR {{extrablankline 0}} {
  1089.     set end [getPos]
  1090.     set start [lineStart $end]
  1091.     set text [getText $start $end]
  1092.     if {![htmlIsWhite $text]} {
  1093.         set r "¥r"
  1094.         if {$extrablankline} {append r "¥r"}
  1095.         return $r
  1096.     } elseif {$start > 0 } { 
  1097.         set prevstart [lineStart [expr $start - 1 ]]
  1098.         set text [getText $prevstart [expr $start - 1]]
  1099.         if {![htmlIsWhite $text] && $extrablankline} {
  1100.             return "¥r"
  1101.         } else { 
  1102.             return
  1103.         }
  1104.     } else {
  1105.         return
  1106.     }
  1107. }
  1108.  
  1109. # Insert a carriage return at the insertion point if any
  1110. # character following the insertion point (on the same line)
  1111. # is a non-whitespace character.
  1112. proc htmlCloseCR {} {
  1113.     set start [getPos]
  1114.     set end [nextLineStart $start]
  1115.     set text [getText $start $end]
  1116.     if {![htmlIsWhite $text]} {
  1117.         return "¥r" 
  1118.     } else {
  1119.         return
  1120.     }
  1121. }
  1122.  
  1123. # Set up tab mark mechanism.
  1124. proc htmlTabGoto {directionIndicator} {
  1125.     set searchResult [search -s -n -f $directionIndicator -m 0 -i 1 -r 0 {･} [getPos]]
  1126.     if {![llength $searchResult] || [lindex $searchResult 0] >= [maxPos]} {
  1127.         beep
  1128.         message "Tab mark not found."
  1129.         return 0
  1130.     } else {
  1131.         goto [lindex $searchResult 0]
  1132.         return 1
  1133.     }
  1134. }
  1135.  
  1136. proc htmlTabNext {} {
  1137.     if {[htmlTabGoto 1]} {deleteChar}
  1138. }
  1139.  
  1140. proc htmlTabPrev {} {
  1141.     if {[htmlTabGoto 0]} {deleteChar}
  1142. }
  1143.  
  1144. # Removes all tab marks from the current selection (if there is one) 
  1145. # or the current document, maintaining the cursor position in the 
  1146. # latter case. Stolen from latexMacros.tcl written by Tom Scavo.
  1147. proc htmlTabDeleteAll {} {
  1148.  
  1149.     set subs1 0; set subs2 0; set subs3 0
  1150.     set pos [getPos]
  1151.     if {[set start $pos] == [set end [selEnd]]} {
  1152.         set messageString "document"
  1153.         set start 0
  1154.         set end [maxPos]
  1155.         set text1 [getText $start $pos]
  1156.         set subs1 [regsub -all {･} $text1 {} text1]
  1157.         set text2 [getText $pos $end]
  1158.         set subs2 [regsub -all {･} $text2 {} text2]
  1159.         append text $text1 $text2
  1160.     } else {
  1161.         set messageString "selection"
  1162.         set text [getText $start $end]
  1163.         set subs3 [regsub -all {･} $text {} text]
  1164.     }
  1165.     if {$subs1 || $subs2 || $subs3} then {
  1166.         replaceText $start $end $text
  1167.         if {$messageString == "document"} then {
  1168.             goto [expr $pos - $subs1]
  1169.         } else {
  1170.             set end [getPos]
  1171.             select $start $end
  1172.         }
  1173.         set subs [expr $subs1 + $subs2 + $subs3]
  1174.         message "$subs tab marks removed from $messageString."
  1175.     } else {
  1176.         message "No tab marks found in $messageString."
  1177.     }
  1178. }
  1179.  
  1180. #
  1181. # Converting  characters to HTML entities.
  1182. #
  1183. proc htmlCharacterstohtml {} {
  1184.     global htmlSpecialCharacter 
  1185.     global htmlSpecialCapCharacter htmlSpecialSymbCharacter
  1186.     
  1187.     message "Translatingﾉ"
  1188.     foreach a [array names htmlSpecialCharacter] {
  1189.         if { $a != "eth" && $a != "thorn" && $a != "yｫ"} { 
  1190.             lappend charlist $a
  1191.         }
  1192.     }
  1193.  
  1194.     foreach a [array names htmlSpecialCapCharacter] {
  1195.         if {$a != "ETH" && $a != "THORN" && $a != "Yｫ"} { 
  1196.             lappend charlist $a
  1197.         }
  1198.     }
  1199.     lappend charlist ﾁ ﾀ
  1200.  
  1201.     set subs1 0;  set lett 0
  1202.     set pos [getPos]
  1203.     if {[set start $pos] == [set end [selEnd]]} {
  1204.         set messageString "document"
  1205.         set start 0
  1206.         set end [maxPos]
  1207.         set text1 [getText $start $pos]
  1208.         set text2 [getText $pos $end]
  1209.         set isDoc 1
  1210.     } else {
  1211.         set messageString "selection"
  1212.         set text1 [getText $start $end]
  1213.         set isDoc 0
  1214.     }
  1215.     
  1216.     foreach char $charlist {
  1217.  
  1218.         if {[info exists htmlSpecialCharacter($char)]} {
  1219.             set rtext "¥¥&$htmlSpecialCharacter($char);"
  1220.         } elseif {[info exists htmlSpecialCapCharacter($char)]} {
  1221.             set rtext "¥¥&$htmlSpecialCapCharacter($char);"
  1222.         } else {
  1223.             set rtext "¥¥&$htmlSpecialSymbCharacter($char);"
  1224.         }
  1225.         
  1226.         set subNum [regsub -all $char $text1 [set rtext] text1]
  1227.         incr subs1 [expr $subNum * ([string length $rtext] - 2)]
  1228.         incr lett $subNum
  1229.         if {$isDoc} {
  1230.             set subNum [regsub -all $char $text2 [set rtext] text2]
  1231.             incr lett $subNum
  1232.         }
  1233.         
  1234.     }
  1235.     set text $text1
  1236.     if {$isDoc} {append text $text2}
  1237.     if {$lett} {
  1238.         replaceText $start $end $text
  1239.         if {$isDoc} {
  1240.             goto [expr $pos + $subs1]
  1241.         } else {
  1242.             set end [getPos]
  1243.             select $start $end
  1244.         }
  1245.     }
  1246.     message "$lett characters translated in $messageString."
  1247. }
  1248.  
  1249.  
  1250.  
  1251. #
  1252. # Converting HTML entities to characters.
  1253. #
  1254.  
  1255. proc htmltoCharacters {} {
  1256.     global htmlCharacterSpecial  
  1257.     global htmlCapCharacterSpecial 
  1258.     
  1259.     message "Translatingﾉ"
  1260.     
  1261.     foreach a [array names htmlCharacterSpecial] {
  1262.         if { $a != "eth" && $a != "thorn" && $a != "yｫ"} { 
  1263.             lappend entitylist "&$a;"
  1264.         }
  1265.     }
  1266.  
  1267.     foreach a [array names htmlCapCharacterSpecial] {
  1268.         if {$a != "ETH" && $a != "THORN" && $a != "Yｫ"} { 
  1269.             lappend entitylist "&$a;"
  1270.         }
  1271.     }
  1272.     
  1273.     # ﾁ ﾀ
  1274.     lappend entitylist "¡" "¿"
  1275.     set subs1 0;  set lett 0
  1276.     set pos [getPos]
  1277.     if {[set start $pos] == [set end [selEnd]]} {
  1278.         # Move position to linestart to make sure no letter is split.
  1279.         set pos [lineStart $pos]
  1280.         set messageString "document"
  1281.         set start 0
  1282.         set end [maxPos]
  1283.         set text1 [getText $start $pos]
  1284.         set text2 [getText $pos $end]
  1285.         set isDoc 1
  1286.     } else {
  1287.         set messageString "selection"
  1288.         set text1 [getText $start $end]
  1289.         set isDoc 0
  1290.     }
  1291.  
  1292.     foreach char $entitylist {
  1293.         set schar [string range $char 1 [expr [string length $char] - 2]]
  1294.         if {[info exists htmlCharacterSpecial($schar)]} {
  1295.             set rtext "$htmlCharacterSpecial($schar)"
  1296.         } elseif {[info exists htmlCapCharacterSpecial($schar)]} {
  1297.             set rtext "$htmlCapCharacterSpecial($schar)"
  1298.         } elseif {$schar == "#161"} {
  1299.             set rtext ﾁ
  1300.         } elseif {$schar == "#191"} {
  1301.             set rtext ﾀ
  1302.         }
  1303.         
  1304.         set subNum [regsub -all $char $text1 $rtext text1]
  1305.         incr subs1 [expr $subNum * ([string length $char] - 1)]
  1306.         incr lett $subNum
  1307.         if {$isDoc} {
  1308.             set subNum [regsub -all $char $text2 $rtext text2]
  1309.             incr lett $subNum
  1310.         }
  1311.         
  1312.     }
  1313.     set text $text1
  1314.     if {$isDoc} {append text $text2}
  1315.     if {$lett} {
  1316.         replaceText $start $end $text
  1317.         if {$isDoc} {
  1318.             goto [expr $pos - $subs1]
  1319.         } else {
  1320.             set end [getPos]
  1321.             select $start $end
  1322.         }
  1323.     }
  1324.     message "$lett characters translated in $messageString."
  1325. }
  1326.  
  1327. # Puts up a window with error text.
  1328.  
  1329. proc htmlErrorWindow {errHeader errText {cancelButton 0}} {
  1330.     
  1331.     set errbox "-t {$errHeader} 100 10 400 25"
  1332.     set hpos 35
  1333.     foreach err $errText {
  1334.         lappend errbox -t $err 10 $hpos 400 [expr $hpos + 15]
  1335.         incr hpos 20
  1336.     }
  1337.     if {$cancelButton} {
  1338.         lappend errbox -b Cancel 125 [expr $hpos + 20 ] 190 [expr $hpos + 40 ]
  1339.     }
  1340.     
  1341.     set val [eval [concat dialog -w 430 -h [expr $hpos + 60 ] ¥
  1342.     -b OK 40 [expr $hpos + 20 ] 105 [expr $hpos + 40 ] $errbox]]
  1343.     return [lindex $val 0]
  1344. }
  1345.  
  1346.  
  1347. #===============================================================================
  1348. # Building tags, including element attributes
  1349. #===============================================================================
  1350.  
  1351. # Six functions to get element variables from the right package.
  1352.  
  1353. proc htmlGetRequired {item} {
  1354.     global htmlPackageToUse
  1355.     global htmlElemAttrRequired1 htmlElemAttrRequired3
  1356.     
  1357.     if {[catch {set reqatts [set htmlElemAttrRequired${htmlPackageToUse}($item)]}]} { set reqatts {} } 
  1358.     return $reqatts
  1359. }
  1360.  
  1361. proc htmlGetOptional {item} {
  1362.     global htmlPackageToUse
  1363.     global htmlElemAttrOptional1 htmlElemAttrOptional3
  1364.     
  1365.     if {[catch {set optatts [set htmlElemAttrOptional${htmlPackageToUse}($item)]}]} { set optatts {} } 
  1366.     return $optatts
  1367. }
  1368.  
  1369.  
  1370. proc htmlGetNumber {item} {
  1371.     global htmlPackageToUse
  1372.     global htmlElemAttrNumber1 htmlElemAttrNumber3
  1373.     
  1374.     if {[catch {set numatts [set htmlElemAttrNumber${htmlPackageToUse}($item)]}]} { set numatts {} } 
  1375.     return $numatts
  1376. }
  1377.  
  1378. proc htmlGetChoices {item} {
  1379.     global htmlPackageToUse
  1380.     global htmlElemAttrChoices1 htmlElemAttrChoices3
  1381.     
  1382.     if {[catch {set choiceatts [set htmlElemAttrChoices${htmlPackageToUse}($item)]}]} { set choiceatts {} }
  1383.     return $choiceatts
  1384. }
  1385.  
  1386. proc htmlGetUsed {item} {
  1387.     global htmlPackageToUse
  1388.     global htmlElemAttrUsed htmlElemAttrUsed3
  1389.     if {$htmlPackageToUse == 1} {
  1390.         set num ""
  1391.     } else {
  1392.         set num 3
  1393.     }
  1394.     if {[catch {set useatts [set htmlElemAttrUsed${num}($item)]}]} { set useatts {} }
  1395.     return $useatts
  1396. }
  1397.  
  1398. proc htmlGetAttrMore {item} {
  1399.     global htmlPackageToUse
  1400.     global htmlElemAttrMore htmlElemAttrMore3
  1401.     
  1402.     if {$htmlPackageToUse == 1} {
  1403.         set num ""
  1404.     } else {
  1405.         set num 3
  1406.     }
  1407.     if {[catch {set askformore [set htmlElemAttrMore${num}($item)]}]} { set askformore 0 }
  1408.     return $askformore
  1409. }
  1410.  
  1411. proc htmlOpenElem {elem {used ""}} {
  1412.     global HTMLmodeVars 
  1413.     if {$HTMLmodeVars(useBigWindows)} {
  1414.         return [htmlOpenElemWindow $elem $used]
  1415.     } else {
  1416.         return [htmlOpenElemLoop $elem $used]
  1417.     }
  1418. }
  1419.  
  1420. # Opening or only tag of an element - include attributes
  1421. # Big window with all attributes.
  1422. # Return empty string if user clicks "Cancel".
  1423.  
  1424. proc htmlOpenElemWindow {elem used {values ""}} {
  1425.     global HTMLmodeVars  htmlColorName htmlElemEventHandler1
  1426.     global  htmluserColors basicColors htmlPackageToUse
  1427.     global htmlURLAttr htmlColorAttr  htmlWindowAttr
  1428.     global htmlSpecURL htmlSpecColor htmlSpecWindow
  1429.     
  1430.     set URLs $HTMLmodeVars(URLs)
  1431.     set Windows $HTMLmodeVars(windows)
  1432.     
  1433. # put users colours first
  1434.     set htmlColors [lsort [array names htmluserColors]]
  1435.      append htmlColors " " $basicColors
  1436.  
  1437.     if {![string length $used]} {set used $elem}
  1438.     set elem [string toupper $elem]
  1439.     set used [string toupper $used]
  1440.     
  1441.     # get variables for the element
  1442.     set reqatts [htmlGetRequired $used]
  1443.     set numatts [htmlGetNumber $used]
  1444.     set optatts [htmlGetOptional $used]
  1445.     set choiceatts [htmlGetChoices $used]
  1446.  
  1447.     set allatts [concat $reqatts $optatts]
  1448.  
  1449.     # optionally include event handlers
  1450.     if {$HTMLmodeVars(inclEventHandler) && $htmlPackageToUse == 1 && ¥
  1451.     [info exists htmlElemEventHandler1($used)]} {
  1452.         set eventatts $htmlElemEventHandler1($used)
  1453.         append allatts " " $eventatts
  1454.     } else {
  1455.         set eventatts ""
  1456.     }
  1457.  
  1458.     # if there are attributes to ask about, do so
  1459.  
  1460.     set text "<"
  1461.     append text  [htmlSetCase $elem] 
  1462.  
  1463.     set maxHeight [expr [lindex [getMainDevice] 3] - 115]
  1464.     set thisPage "Page 1"
  1465.  
  1466.     if {[llength $allatts]} { 
  1467.         # build window with attributes 
  1468.         set invalidInput 1
  1469.         while {$invalidInput} {
  1470.             while {1} {
  1471.                 if {$used == "LI IN UL" || $used == "LI IN OL"} {
  1472.                     set pr LI
  1473.                 } else {
  1474.                     set pr $used
  1475.                 }
  1476.                 set box1 "-t {Attributes for $pr} 120 10 320 25"
  1477.                 set box2 "-t {Attributes for $pr} 120 10 320 25"
  1478.                 set box3 "-t {Attributes for $pr} 120 10 320 25"
  1479.                 set page 1
  1480.                 set attrtypes {}
  1481.                 set fileIndex ""
  1482.                 set colorIndex ""
  1483.                 set wpos 10
  1484.                 if {[string length $reqatts]} {
  1485.                     lappend box$page -p 120 30 270 31 -t {Required attributes} 10 35 200 50
  1486.                     set hpos 60
  1487.                 } else {
  1488.                     set hpos 30
  1489.                 }
  1490.                 set attrIndex 2
  1491.                 for {set i 0} {$i < [llength $allatts]} {incr i} {
  1492.                     set attr [lindex $allatts $i]
  1493.                     if {$i == [llength $reqatts]} {
  1494.                         if {$wpos > 20} { incr hpos 20 }
  1495.                         lappend box$page -p 120 $hpos 270 [expr $hpos + 1] ¥
  1496.                         -t {Optional attributes} 10 [expr $hpos + 5] 200 [expr $hpos + 20]
  1497.                         set wpos 10
  1498.                         incr hpos 30
  1499.                     }
  1500.                     set a2 [string trimright $attr =]
  1501.                     if {([lsearch -exact $htmlURLAttr $attr] >= 0 && [lsearch -exact $htmlSpecURL "${used}!=$a2"] < 0) || ¥
  1502.                     [lsearch -exact $htmlSpecURL "${used}=$a2"] >= 0} { 
  1503.                         # URL
  1504.                         if {$wpos > 20} { incr hpos 25 ; set wpos 10}
  1505.                         if {[expr $hpos + 45] > $maxHeight && $page < 3} {
  1506.                             incr page
  1507.                             set hpos 40
  1508.                         }
  1509.                         if {[llength values]} {
  1510.                             set etxt [lindex $values $attrIndex]
  1511.                             set mtxt [lindex $values [expr $attrIndex + 1]]
  1512.                             incr attrIndex 3 
  1513.                         } else {
  1514.                             set etxt ""
  1515.                             set mtxt {No value}
  1516.                         }
  1517.                         lappend box$page -t $attr 10 $hpos 120 [expr $hpos + 15] ¥
  1518.                         -e $etxt 120 $hpos 450 [expr $hpos + 15] ¥
  1519.                         -m [concat [list $mtxt {No value}] $URLs] ¥
  1520.                         120 [expr $hpos + 25] 450 [expr $hpos + 35] ¥
  1521.                         -b "Fileﾉ" 10 [expr $hpos + 20] 70 [expr $hpos + 40]
  1522.                         incr hpos 50
  1523.                         lappend attrtypes url
  1524.                         lappend fileIndex [expr $attrIndex - 1]
  1525.                     } elseif {([lsearch -exact $htmlColorAttr $attr] >= 0 && [lsearch -exact $htmlSpecColor "${used}!=$a2"] < 0) || ¥
  1526.                     [lsearch -exact $htmlSpecColor "${used}=$a2"] >= 0} { 
  1527.                         # Color attribute
  1528.                         if {$wpos > 20} { incr hpos 25 ; set wpos 10}                    
  1529.                         if {[expr $hpos + 25] > $maxHeight && $page < 3} {
  1530.                             incr page
  1531.                             set hpos 40
  1532.                         }
  1533.                         if {[llength values]} {
  1534.                             set etxt [lindex $values $attrIndex]
  1535.                             set mtxt [lindex $values [expr $attrIndex + 1]]
  1536.                             incr attrIndex 3
  1537.                         } else {
  1538.                             set etxt ""
  1539.                             set mtxt {No value}
  1540.                         }
  1541.                         lappend box$page -t $attr 10 $hpos 120 [expr $hpos + 15] ¥
  1542.                         -e $etxt 120 $hpos 190 [expr $hpos + 15] ¥
  1543.                         -m [concat [list $mtxt {No value}] $htmlColors] ¥
  1544.                         200 $hpos 340 [expr $hpos + 15] ¥
  1545.                         -b "New Colorﾉ" 350 $hpos 450 [expr $hpos + 20]
  1546.                         incr hpos 30
  1547.                         lappend attrtypes color
  1548.                         lappend colorIndex [expr $attrIndex - 1]
  1549.                     } elseif {([lsearch -exact $htmlWindowAttr $attr] >= 0 && [lsearch -exact $htmlSpecWindow "${used}!=$a2"] < 0) || ¥
  1550.                     [lsearch -exact $htmlSpecWindow "${used}=$a2"] >= 0} { 
  1551.                         # Window attribute
  1552.                         if {$wpos > 20} { incr hpos 25 ; set wpos 10}                    
  1553.                         if {[expr $hpos + 25] > $maxHeight && $page < 3} {
  1554.                             incr page
  1555.                             set hpos 40
  1556.                         }
  1557.                         if {[llength values]} {
  1558.                             set etxt [lindex $values $attrIndex]
  1559.                             set mtxt [lindex $values [expr $attrIndex + 1]]
  1560.                             incr attrIndex 2
  1561.                         } else {
  1562.                             set etxt ""
  1563.                             set mtxt {No value}
  1564.                         }
  1565.                         lappend box$page -t $attr 10 $hpos 120 [expr $hpos + 15] ¥
  1566.                         -e $etxt 120 $hpos 240 [expr $hpos + 15] ¥
  1567.                         -m [concat [list $mtxt {No value}] ¥
  1568.                         [concat {_SELF _TOP _PARENT _BLANK} $Windows]] ¥
  1569.                         250 $hpos 440 [expr $hpos + 15]
  1570.                         incr hpos 30
  1571.                         lappend attrtypes window
  1572.                     } elseif {[lsearch $numatts "${attr}*"] >= 0} { 
  1573.                         # Number
  1574.                         if {[expr $hpos + 20] > $maxHeight && $wpos < 20 && $page < 3} {
  1575.                             incr page
  1576.                             set hpos 40
  1577.                         }
  1578.                         if {[llength values]} {
  1579.                             set etxt [lindex $values $attrIndex]
  1580.                             incr attrIndex 
  1581.                         } else {
  1582.                             set etxt ""
  1583.                         }
  1584.                         lappend box$page -t $attr $wpos $hpos [expr $wpos + 100] [expr $hpos + 15] ¥
  1585.                         -e $etxt [expr $wpos + 110] $hpos [expr $wpos + 150] [expr $hpos + 15]
  1586.                         if {$wpos > 20} { 
  1587.                             incr hpos 25
  1588.                             set wpos 10
  1589.                         } else {
  1590.                             set wpos 230
  1591.                         }
  1592.                         lappend attrtypes number
  1593.                     } elseif {[string match "*${attr}*" $choiceatts] && [string index $attr [expr [string length $attr] - 1]] == "="} { 
  1594.                         # Choices
  1595.                         if {[expr $hpos + 20] > $maxHeight && $wpos < 20 && $page < 3} {
  1596.                             incr page
  1597.                             set hpos 40
  1598.                         }
  1599.                         set matches {}
  1600.                         foreach w $choiceatts {
  1601.                             if {[string match "${attr}*" $w]} {
  1602.                                 lappend matches  [string range $w [string length $attr] end]
  1603.                             }    
  1604.                         }
  1605.                         if {[llength values]} {
  1606.                             set mtxt [lindex $values $attrIndex]
  1607.                             incr attrIndex 
  1608.                         } else {
  1609.                             set mtxt {No value}
  1610.                         }
  1611.                         lappend box$page -t $attr $wpos $hpos [expr $wpos + 100] [expr $hpos + 15] ¥
  1612.                         -m [concat [list $mtxt {No value}] $matches] ¥
  1613.                         [expr $wpos + 110] $hpos [expr $wpos + 205] [expr $hpos + 15]
  1614.                         if {$wpos > 20} { 
  1615.                             incr hpos 25 
  1616.                             set wpos 10
  1617.                         } else {
  1618.                             set wpos 230
  1619.                         }    
  1620.                         lappend attrtypes choices
  1621.                     } elseif {[string index $attr [expr [string length $attr] - 1]] == "="} {
  1622.                         # Any other
  1623.                         if {$wpos > 20} { incr hpos 25 ; set wpos 10}                    
  1624.                         if {[expr $hpos + 20] > $maxHeight && $page < 3} {
  1625.                             incr page
  1626.                             set hpos 40
  1627.                         }
  1628.                         if {[llength values]} {
  1629.                             set etxt [lindex $values $attrIndex]
  1630.                             incr attrIndex
  1631.                         } else {
  1632.                             set etxt ""
  1633.                         }
  1634.                         lappend box$page -t $attr 10 $hpos 120 [expr $hpos + 15] ¥
  1635.                         -e $etxt 120 $hpos 450 [expr $hpos + 15] 
  1636.                         incr hpos 25
  1637.                         lappend attrtypes any
  1638.                     } else { 
  1639.                         # Flag
  1640.                         if {[expr $hpos + 20] > $maxHeight && $wpos < 20 && $page < 3} {
  1641.                             incr page
  1642.                             set hpos 40
  1643.                         }
  1644.                         if {[llength values]} {
  1645.                             set ctxt [lindex $values $attrIndex]
  1646.                             incr attrIndex 
  1647.                         } else {
  1648.                             set ctxt 0
  1649.                         }
  1650.                         lappend box$page -c $attr $ctxt $wpos $hpos [expr $wpos + 100] [expr $hpos + 15]
  1651.                         if {$wpos > 20} { 
  1652.                             incr hpos 25
  1653.                             set wpos 10
  1654.                         } else {
  1655.                             set wpos 230
  1656.                         }
  1657.                         lappend attrtypes flag
  1658.                     }
  1659.                 }
  1660.                 if {$wpos > 20} { incr hpos 25 }
  1661.                 
  1662.                 if {$page == 1} {
  1663.                     set box $box1
  1664.                 } elseif {$page == 2} {
  1665.                     set hpos $maxHeight
  1666.                     set box " -m ¥{¥{$thisPage¥} ¥{Page 1¥} ¥{Page 2¥}¥} 10 10 85 30 -n ¥{Page 1¥} $box1 -n ¥{Page 2¥} $box2"
  1667.                 } elseif {$page == 3} {
  1668.                     set hpos $maxHeight
  1669.                     set box " -m ¥{¥{$thisPage¥} ¥{Page 1¥} ¥{Page 2¥} ¥{Page 3¥}¥} 10 10 85 30 -n ¥{Page 1¥} $box1 -n ¥{Page 2¥} $box2 -n ¥{Page 3¥} $box3"
  1670.                 }
  1671.                 set values [eval [concat dialog -w 460 -h [expr $hpos + 50] ¥
  1672.                 -b OK 20 [expr $hpos + 20]  85 [expr $hpos + 40] ¥
  1673.                 -b Cancel 110 [expr $hpos + 20] 175 [expr $hpos + 40] $box]]
  1674.                 # If two pages...
  1675.                 if {$page > 1} {
  1676.                     set thisPage [lindex $values 2]
  1677.                     set values [lreplace $values 2 2]
  1678.                 }
  1679.                 
  1680.                 # OK button clicked?
  1681.                 if {[lindex $values 0] } { break }
  1682.                 # Cancel button clicked?
  1683.                 if {[lindex $values 1] } { return}
  1684.                 # File button clicked?
  1685.                 foreach fl $fileIndex {
  1686.                     if {[lindex $values $fl]} {
  1687.                         set newFile [htmlGetFile]
  1688.                         if {[string length $newFile]} {
  1689.                             set URLs $HTMLmodeVars(URLs)
  1690.                             set values [lreplace $values [expr $fl - 1] [expr $fl - 1] $newFile]
  1691.                         }
  1692.                     }
  1693.                 }
  1694.                 # Color button clicked?
  1695.                 foreach cl $colorIndex {
  1696.                     if {[lindex $values $cl]} {
  1697.                         set newcolor [htmlAddNewColor]
  1698.                         if {[string length $newcolor]} { 
  1699.                             set htmlColors [concat [list $newcolor] $htmlColors]
  1700.                             set values [lreplace $values [expr $cl - 1] [expr $cl - 1] "$newcolor"]
  1701.                         }
  1702.                     }
  1703.                 }
  1704.             }
  1705.             
  1706.             
  1707.             # put everything together
  1708.             set attrtext ""
  1709.             set errtext ""
  1710.             if {[lindex $values 0]} {
  1711.                 set j 2
  1712.                 for {set i 0} {$i < [llength $attrtypes]} {incr i} {
  1713.                     set attr [lindex $allatts $i]                
  1714.                     switch [lindex $attrtypes $i] {
  1715.                         url {
  1716.                             set texturl [string trim [lindex $values $j]]
  1717.                             set menuurl [lindex $values [expr $j + 1]]
  1718.                             if {[string length $texturl]} {        
  1719.                                 append attrtext " " [htmlSetCase $attr] ¥
  1720.                                 [htmlAddQuotes $texturl] 
  1721.                                 htmlAddToCache URLs $texturl
  1722.                             } elseif {$menuurl != "No value"} {
  1723.                                 append attrtext " " [htmlSetCase $attr] ¥
  1724.                                 [htmlAddQuotes $menuurl] 
  1725.                             } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1726.                                 lappend errtext "$attr required."
  1727.                             }
  1728.                             incr j 3
  1729.                         }
  1730.                         color {
  1731.                             set colortxt [lindex $values $j]
  1732.                             set colorval [lindex $values [expr $j + 1]]
  1733.                             if {[string length $colortxt]} {
  1734.                                 set col [htmlCheckColorNumber $colortxt]
  1735.                                  if {$col == 0} {
  1736.                                      lappend errtext "$attr: $colortxt is not a valid color number."
  1737.                                 } else {    
  1738.                                     append attrtext " " [htmlSetCase $attr] ¥
  1739.                                     [htmlAddQuotes $col]
  1740.                                 }
  1741.                             } elseif {$colorval != "No value"} {
  1742.                                 # Users own color?
  1743.                                 if {[info exists htmluserColors($colorval)]} {
  1744.                                     set colornum $htmluserColors($colorval)
  1745.                                 }
  1746.                                 # Predefined color?
  1747.                                 if {[info exists htmlColorName($colorval)]} {
  1748.                                     set colornum $htmlColorName($colorval)
  1749.                                 }
  1750.                                 append attrtext " " [htmlSetCase $attr] ¥
  1751.                                 [htmlAddQuotes $colornum] 
  1752.                             } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1753.                                 lappend errtext "$attr required."
  1754.                             }
  1755.                             incr j 3
  1756.                         }
  1757.                         window {
  1758.                             set textwin [string trim [lindex $values $j]]
  1759.                             set menuwin [lindex $values [expr $j + 1]]
  1760.                             if {[string length $textwin]} {        
  1761.                                 append attrtext " " [htmlSetCase $attr] ¥
  1762.                                 [htmlAddQuotes $textwin] 
  1763.                                 htmlAddToCache windows $textwin
  1764.                             } elseif {$menuwin != "No value"} {
  1765.                                 append attrtext " " [htmlSetCase $attr] ¥
  1766.                                 [htmlAddQuotes $menuwin] 
  1767.                             } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1768.                                 lappend errtext "$attr required."
  1769.                             }
  1770.                             incr j 2
  1771.                         }
  1772.                         number {
  1773.                             set numval [string trim [lindex $values $j]]
  1774.                             if {[string length $numval]} {
  1775.                                 if {[htmlCheckAttrNumber $used $attr $numval] == 1} {        
  1776.                                     append attrtext " " [htmlSetCase $attr] ¥
  1777.                                     [htmlAddQuotes $numval] 
  1778.                                 } else {
  1779.                                     lappend errtext "$attr: [htmlCheckAttrNumber $used $attr $numval]"
  1780.                                 }
  1781.                             } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1782.                                 lappend errtext "$attr required."
  1783.                             }
  1784.                             incr j
  1785.                         }
  1786.                         choices {
  1787.                             set choiceval [lindex $values $j]
  1788.                             if {$choiceval != "No value"} {        
  1789.                                 append attrtext " " [htmlSetCase $attr] 
  1790.                                 set qchoice [htmlAddQuotes $choiceval]
  1791.                                 if {($used != "LI IN OL" && $used != "OL") || $attr != "TYPE="} {
  1792.                                     set qchoice [htmlSetCase $qchoice]
  1793.                                 }
  1794.                                 append attrtext $qchoice
  1795.                             } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1796.                                 lappend errtext "$attr required."
  1797.                             }
  1798.                             incr j
  1799.                         }
  1800.                         any {
  1801.                             set anyval [lindex $values $j]
  1802.                             # Trim only if it's only spaces.
  1803.                             if {[string trim $anyval] == ""} {set anyval ""}
  1804.                             if {[string length $anyval]} {
  1805.                                 if {[lsearch -exact $eventatts $attr] < 0} {
  1806.                                     set attr [htmlSetCase $attr]
  1807.                                 }
  1808.                                 append attrtext " " $attr [htmlAddQuotes $anyval] 
  1809.                                 htmlOpenExtraThings $used $attr $anyval
  1810.                             } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1811.                                 lappend errtext "$attr required."
  1812.                             }
  1813.                             incr j
  1814.                         }
  1815.                         flag {
  1816.                             set flagval [lindex $values $j]
  1817.                             if {$flagval} {        
  1818.                                 append attrtext " " [htmlSetCase $attr] 
  1819.                             }
  1820.                             incr j
  1821.                         }
  1822.                     }
  1823.                 }
  1824.                 # If everything is OK, add the attribute text to text.
  1825.                 if {![llength $errtext]} {
  1826.                     append text $attrtext
  1827.                     set invalidInput 0
  1828.                 } else {
  1829.                     # Put up alert with the error text.
  1830.                     htmlErrorWindow "Invalid input for $used" $errtext
  1831.                 }
  1832.                 # Some tests that input is ok.
  1833.                 if {!$invalidInput} {set invalidInput [htmlFontBaseTest $text alertnote]}
  1834.                 if {!$invalidInput && $elem == "A" && [set invalidInput [htmlATest $text alertnote]]} {
  1835.                     set text "<[htmlSetCase A]"
  1836.                 }
  1837.                 if {!$invalidInput && $elem == "FRAMESET" && [set invalidInput [htmlFramesetTest $text alertnote]]} {
  1838.                     set text "<[htmlSetCase FRAMESET]"
  1839.                 }
  1840.                 if {!$invalidInput && $elem == "SPACER" && [set invalidInput [htmlSpacerTest $text alertnote]]} {
  1841.                     set text "<[htmlSetCase SPACER]"
  1842.                 }
  1843.                 if {!$invalidInput && $elem == "AREA" && [set invalidInput [htmlAreaTest $text alertnote]]} {
  1844.                     set text "<[htmlSetCase AREA]"
  1845.                 }
  1846.             } else {
  1847.                 set text ""
  1848.             }    
  1849.         }
  1850.     }
  1851.     
  1852.     if {[string length $text] } {append text ">"}
  1853.     
  1854.     return ${text}
  1855. }
  1856.  
  1857. # these two require at least one of several optional attributes
  1858. proc htmlFontBaseTest {text cmd} {
  1859.     if {([string toupper $text] == "<FONT" || [string toupper $text] == "<BASE" )} {  
  1860.         eval {$cmd "At least one of the attributes is required."}
  1861.         return 1
  1862.     }
  1863.     return 0
  1864. }
  1865.  
  1866. # HREF or NAME must be used for A.
  1867. proc htmlATest {text cmd} {
  1868.     if {![regexp -nocase {href=} $text] && ![regexp -nocase {name=} $text]} {
  1869.         eval {$cmd "At least one of the attributes HREF and NAME must be used."}
  1870.         return 1
  1871.     }
  1872.     return 0
  1873. }
  1874.  
  1875. # ROWS or COLS must be used for FRAMESET
  1876. proc htmlFramesetTest {text cmd} {
  1877.     if {![regexp -nocase {rows=} $text] && ![regexp -nocase {cols=} $text]} {
  1878.         eval {$cmd "At least one of the attributes ROWS and COLS must be used."}
  1879.         return 1
  1880.     }
  1881.     return 0
  1882. }
  1883.  
  1884. # Some checks for SPACER.
  1885. proc htmlSpacerTest {text cmd} {
  1886.         set horver [regexp -nocase {type=¥"(horizontal|vertical)¥"} $text]
  1887.         set wh [regexp -nocase {width=|height=} $text]
  1888.         set sz [regexp -nocase {size=} $text]
  1889.         set al [regexp -nocase {align=} $text]
  1890.         set invalidInput 1
  1891.         if {$horver && ($wh || $al)} {
  1892.             eval {$cmd "WIDTH, HEIGHT and ALIGN should only be used when TYPE=BLOCK."}
  1893.         } elseif {!$horver && $sz} {
  1894.             eval {$cmd "SIZE should only be used when TYPE=HORIZONTAL or VERTICAL."}
  1895.         } elseif {$horver && !$sz} {
  1896.             eval {$cmd "SIZE is required when TYPE=HORIZONTAL or VERTICAL."}
  1897.         } elseif {!$horver && !$wh} {
  1898.             eval {$cmd "WIDTH or HEIGHT is required when TYPE=BLOCK."}
  1899.         } else {
  1900.             set invalidInput 0
  1901.         }
  1902.         return $invalidInput
  1903. }
  1904.  
  1905. # For AREA, either HREF or NOHREF must be used, but not both.
  1906. proc htmlAreaTest {text cmd} {
  1907.     set hasHref [regexp -nocase {href=} $text]
  1908.     set hasNohref [regexp -nocase {nohref} $text]
  1909.     set hasCoords [regexp -nocase {coords=} $text]
  1910.     set shapeDefault [regexp -nocase {shape=¥"default¥"} $text]
  1911.     set invalidInput 0
  1912.     if {($hasHref && $hasNohref) || (!$hasHref && !$hasNohref)} {
  1913.         eval {$cmd "One of the attributes HREF and NOHREF must be used, but not both."}
  1914.         set invalidInput 1
  1915.     } elseif {!$hasCoords && !$shapeDefault} {
  1916.         eval {$cmd "COORDS= is required if SHAPEｭDEFAULT"}
  1917.         set invalidInput 1
  1918.     }
  1919.     return $invalidInput
  1920. }
  1921.  
  1922. # Adds a NAME= value to cache.
  1923. proc htmlOpenExtraThings {elem attr val} {
  1924.     if {[lsearch -exact {A MAP} $elem] >= 0 && $attr == "NAME="} {
  1925.         htmlAddToCache URLs "#$val"
  1926.     }
  1927.     if {$elem == "FRAME" && $attr == "NAME="} {
  1928.         htmlAddToCache windows $val
  1929.     }
  1930. }
  1931.  
  1932.  
  1933. # Check if a color number is a valid number.
  1934. # Returns 0 if not and the color number if it is.
  1935. proc htmlCheckColorNumber {color} {
  1936.     if {[string range $color 0 0] != "#"} {
  1937.         set color "#${color}"
  1938.     }
  1939.     set color [string toupper $color]
  1940.     set testColor ""
  1941.     regexp {^#[0-9A-F]+} [string range $color 0 end] testColor
  1942.     if {[string length $color] != 7 || $testColor != $color} {
  1943.         return 0
  1944.     } else {
  1945.         return $color
  1946.     }    
  1947. }
  1948.  
  1949.  
  1950. # Adds a URL or window given as input to cache
  1951. proc htmlAddToCache {cache newurl} {
  1952.     global modifiedModeVars HTMLmodeVars
  1953.     
  1954.     if {$cache == "windows" && [lsearch -exact {_SELF _TOP _PARENT _BLANK} [string toupper $newurl]] >= 0} {return}
  1955.     set URLs $HTMLmodeVars($cache)
  1956.     
  1957.     if {[string length $newurl] && [lsearch -exact $URLs $newurl] < 0} { 
  1958.         set URLs [lsort [lappend URLs $newurl]]
  1959.         set HTMLmodeVars($cache) $URLs
  1960.         lappend modifiedModeVars [list $cache HTMLmodeVars]
  1961.     }
  1962. }
  1963.  
  1964. # Check if a input is a valid number for the element attribute.
  1965. # Returns 1 if it is, otherwise returns an error message.
  1966. proc htmlCheckAttrNumber {item attr number} {
  1967.     
  1968.     set attrNumbers [htmlGetNumber $item]
  1969.     set numind [lsearch $attrNumbers "${attr}*"]
  1970.     set numstr [string range [lindex $attrNumbers $numind] [string length $attr] end]
  1971.     regexp {^[-0-9]+} $numstr minvalue
  1972.     set numstr [string range $numstr [expr [string length $minvalue] + 1] end]
  1973.     regexp {^[-i0-9]+} $numstr maxvalue
  1974.     set procent [string range $numstr [expr [string length $numstr] - 1] end]
  1975.     if {$procent == "%"} {
  1976.         set procerr " or percentage"
  1977.     } else {
  1978.         set procerr ""
  1979.     }
  1980.     if {$maxvalue == "i"} {
  1981.         set errtext "A number $minvalue or greater"
  1982.     } else {
  1983.         set errtext "A number in the range $minvalue to $maxvalue"
  1984.     }
  1985.     if {$item == "FONT"} { append errtext " or -6 to +6"}
  1986.     append errtext  "$procerr expected." 
  1987.     # Is percent allowed?
  1988.     if {[string index $number [expr [string length $number] - 1]] == "%" } {
  1989.         set number [string range $number 0 [expr [string length $number] - 2]]
  1990.         if {$procent != "%"} {return $errtext}
  1991.     }
  1992.     # FONT can take values -6 - +6. Special case.
  1993.     if {$item == "FONT" && [regexp {^(¥+|-)[1-6]$} $number]} { return 1}
  1994.     # Is input a number?
  1995.     if {![regexp {^-?[0-9]+$} $number]} {return $errtext}
  1996.     # Is input in the valid range?
  1997.     if {( $maxvalue != "i" && $number > $maxvalue ) || $number < $minvalue } {
  1998.         return $errtext
  1999.     }    
  2000.     return 1 
  2001. }
  2002.  
  2003.  
  2004. # Add quotes to attribute
  2005. proc htmlAddQuotes {v} {
  2006.  
  2007.     if {[string range $v 0 0] != "¥""} {set v  "¥"$v"}
  2008.      set vlen [expr [string length $v] - 1]
  2009.     if {[string range $v $vlen $vlen] !="¥""} {append v "¥""}
  2010.     return $v
  2011. }
  2012.  
  2013.  
  2014. # Closing tag of an element
  2015. proc htmlCloseElem {theElem} {
  2016.     set text ""
  2017.     append text "</"
  2018.     append text [htmlSetCase $theElem]
  2019.     append text ">"
  2020.     return $text
  2021. }
  2022.  
  2023.  
  2024. #
  2025. # Element build routines
  2026. #
  2027.  
  2028. # Build elements with only a opening tag.
  2029. proc htmlBuildOpening {ftype {begCR 0} {endCR 0} {attr ""}} {
  2030.     set text1 ""
  2031.     if {$begCR} { set text1 [htmlOpenCR]}
  2032.     set text [htmlOpenElem $ftype $attr]
  2033.     if {![string length $text]} {return}
  2034.     if {$endCR} {append text "¥r"}
  2035.     insertText $text1 $text
  2036. }
  2037.  
  2038.     
  2039. # This is used for almost all containers
  2040. proc htmlBuildElem {ftype {attr ""}} {
  2041.     global HTMLmodeVars
  2042.     set useTabMarks    $HTMLmodeVars(useTabMarks)
  2043.     global htmlCurSel
  2044.     global htmlIsSel
  2045.  
  2046.     set text [htmlOpenElem $ftype $attr]
  2047. # Check if user has skipped an attribute which can't be skipped.
  2048.     if {![string length $text]} {return}
  2049.     htmlGetSel
  2050.     append text $htmlCurSel
  2051.     set currpos [expr [getPos] + [string length $text]]
  2052.     append text [htmlCloseElem $ftype]
  2053.     if {!$htmlIsSel && $useTabMarks} {append text "･"}
  2054.     if {$htmlIsSel} {
  2055.         replaceText [getPos] [selEnd] $text
  2056.     } else {
  2057.         insertText $text
  2058.         goto $currpos
  2059.     }
  2060. }
  2061.  
  2062. # This is used for elements that should be surrounded by newlines
  2063. proc htmlBuildCRElem {ftype {extrablankline 0} {attr ""}} {
  2064.     global htmlCurSel htmlIsSel
  2065.     global HTMLmodeVars
  2066.     set useTabMarks $HTMLmodeVars(useTabMarks)
  2067.  
  2068.     set text [htmlOpenCR $extrablankline] 
  2069.     set text2 [htmlOpenElem $ftype $attr]
  2070. # Check if user has skipped an attribute which can't be skipped.
  2071.     if {![string length $text2]} {return}
  2072.     append text $text2
  2073.     htmlGetSel
  2074.     append text $htmlCurSel
  2075.     set currpos [expr [getPos] + [string length $text]]
  2076.     append text [htmlCloseElem $ftype]
  2077.     append text "¥r"
  2078.     if {$extrablankline} {append text "¥r"}
  2079.     if {!$htmlIsSel && $useTabMarks} {append text "･"}
  2080.     if {$htmlIsSel} { deleteSelection }
  2081.     insertText $text
  2082.     if {!$htmlIsSel}    {
  2083.         goto $currpos
  2084.     }
  2085.     # There is a bug in undo! Otherwise I would use the following code instead.
  2086. #     if {$htmlIsSel} {
  2087. #         replaceText [getPos] [selEnd] $text
  2088. #     } else {
  2089. #         insertText $text
  2090. #         goto $currpos
  2091. #     }
  2092. }
  2093.  
  2094. # This is used for elements that should be surrounded by empty lines
  2095. proc htmlBuildCR2Elem {ftype {attr ""}} {
  2096.     global HTMLmodeVars htmlCurSel htmlIsSel
  2097.     set useTabMarks    $HTMLmodeVars(useTabMarks)
  2098.     
  2099.     set text [htmlOpenCR 1] 
  2100.     set text2 [htmlOpenElem $ftype $attr]
  2101. # Check if user has skipped an attribute which can't be skipped.
  2102.     if {![string length $text2]} {return}
  2103.     append text $text2
  2104.     htmlGetSel
  2105. # note elems are currently placed at left margin, ignoring current indent
  2106.     append text "¥r$htmlCurSel"
  2107.     set currpos [expr [getPos] + [string length $text]]
  2108.     append text "¥r"
  2109.     append text [htmlCloseElem $ftype]
  2110.     append text "¥r¥r"
  2111.     if {!$htmlIsSel && $useTabMarks} {append text "･"}
  2112.     if {$htmlIsSel} { deleteSelection }
  2113.     insertText $text
  2114.     if {!$htmlIsSel}    {
  2115.         goto $currpos
  2116.     }
  2117.     # There is a bug in undo! Otherwise I would use the following code instead.
  2118. #     if {$htmlIsSel} {
  2119. #         replaceText [getPos] [selEnd] $text
  2120. #     } else {
  2121. #         insertText $text
  2122. #         goto $currpos
  2123. #     }
  2124. }
  2125.  
  2126.  
  2127. #===============================================================================
  2128. # HTML character entities
  2129. #===============================================================================
  2130.  
  2131. proc htmlAddCommonChars {} {
  2132.     global modifiedModeVars HTMLmodeVars htmlSpecialCharacter htmlCapCharSpecMenu
  2133.     global htmlSpecialSymbCharacter
  2134.     set commonChars $HTMLmodeVars(commonChars)
  2135.  
  2136.     foreach a [array names htmlSpecialCharacter] {
  2137.          lappend htmlCharacters $a
  2138.     }
  2139.     set htmlCharacters [lsort $htmlCharacters]
  2140.     foreach a [array names htmlCapCharSpecMenu] {
  2141.          lappend htmlCapCharacters $a
  2142.     }
  2143.     set htmlCapCharacters [lsort $htmlCapCharacters]
  2144.     foreach a [array names htmlSpecialSymbCharacter] {
  2145.          lappend htmlSymbCharacters $a
  2146.     }
  2147.     set htmlSymbCharacters [lsort $htmlSymbCharacters]
  2148.     set htmlAllCharacters [concat $htmlCharacters $htmlCapCharacters $htmlSymbCharacters]
  2149.     if {![catch {listpick -l -p "Select chars for the commonly used char list" ¥
  2150.                 $htmlAllCharacters} newchars]} {
  2151.         set dirty 0
  2152.         foreach c $newchars {
  2153.             if {[lsearch -exact $commonChars $c] < 0} {
  2154.                 set dirty 1
  2155.                 set commonChars [lsort [lappend commonChars $c]]
  2156.             }
  2157.         }
  2158.         if {$dirty} {
  2159.             lappend modifiedModeVars {commonChars HTMLmodeVars}
  2160.             set HTMLmodeVars(commonChars) $commonChars
  2161.             message "Rebuiding HTML menuﾉ"
  2162.             htmlBuildMenu
  2163.             message "New characters added to the common list."
  2164.         }
  2165.     }
  2166. }
  2167.  
  2168. proc htmlDefaultCommonChars {} {
  2169.     global modifiedModeVars HTMLmodeVars
  2170.     
  2171.     if {[askyesno "Revert to default common characters?"] == "yes"} {
  2172.         set HTMLmodeVars(commonChars) $HTMLmodeVars(defaultCommonChars)
  2173.         lappend modifiedModeVars {commonChars HTMLmodeVars}
  2174.         message "Rebuiding HTML menuﾉ"
  2175.         htmlBuildMenu
  2176.         message "Common character list reverted to default."
  2177.     }    
  2178. }
  2179.  
  2180. proc htmlClearCommonChars {} {
  2181.     global modifiedModeVars HTMLmodeVars
  2182.     
  2183.     if {[askyesno "Remove all common characters?"] == "yes"} {
  2184.         set HTMLmodeVars(commonChars) {}
  2185.         lappend modifiedModeVars {commonChars HTMLmodeVars}
  2186.         message "Rebuiding HTML menuﾉ"
  2187.         htmlBuildMenu
  2188.         message "Common character list cleared."
  2189.     }    
  2190. }
  2191.  
  2192. #
  2193. # Insert special character entity
  2194. #
  2195. proc htmlInsertCharacter {char} {
  2196.     global htmlSpecialCharacter htmlCapCharSpecMenu htmlSpecialSymbCharacter
  2197.     global htmlIsSel 
  2198.     
  2199.     htmlGetSel
  2200.     if {$htmlIsSel} { deleteSelection }
  2201.     if {[info exists htmlSpecialCharacter($char)]} {
  2202.         insertText &$htmlSpecialCharacter($char)¥;
  2203.     }
  2204.     if {[info exists htmlCapCharSpecMenu($char)]} {
  2205.         insertText &$htmlCapCharSpecMenu($char)¥;
  2206.     }
  2207.     if {[info exists htmlSpecialSymbCharacter($char)]} {
  2208.         insertText &$htmlSpecialSymbCharacter($char)¥;
  2209.     }
  2210. }
  2211.     
  2212.  
  2213.  
  2214. #===============================================================================
  2215. # General Commands
  2216. #===============================================================================
  2217.  
  2218. # remove containing tags
  2219. proc htmlUnTag {selectit} {
  2220.     set curPos [getPos]
  2221.     set tags [htmlGetContainer $curPos [selEnd]]
  2222.     if {[llength $tags] < 5} {
  2223.         alertnote "Cannot decide on enclosing tags."
  2224.         return
  2225.     }
  2226.     # delete them
  2227.     replaceText [lindex $tags 0] [lindex $tags 3] ¥
  2228.     [getText [lindex $tags 1] [lindex $tags 2]]
  2229.     if {$selectit} {
  2230.         select [lindex $tags 0] ¥
  2231.             [expr [lindex $tags 2] - [lindex $tags 1] + [lindex $tags 0]]
  2232.     } else {
  2233.         if {$curPos < [lindex $tags 1]} {set curPos [lindex $tags 1]}
  2234.         goto [expr $curPos - [lindex $tags 1] + [lindex $tags 0]]
  2235.     }
  2236.     message "[lindex $tags 4] deleted."
  2237. }
  2238.  
  2239. # select container, like Balance (cmd-B)
  2240. proc htmlBalance {} {
  2241.     # if </, stay there.  If <?, back up one if possible
  2242.     # watch out for end of file, beginning of file
  2243.     set begin [getPos]
  2244.     set end   [selEnd]
  2245.     
  2246.     set start $begin
  2247.     if {$start != 0 &&
  2248.             ![catch {getText $start [expr $start + 2]} lookingAt] &&
  2249.             $lookingAt != "</" &&
  2250.             [string range $lookingAt 0 0] == "<"} {
  2251.         set start [expr [getPos] - 1]
  2252.     }
  2253.     set tags [htmlGetContainer $start $end]
  2254.     if {[llength $tags] == 5} {
  2255.         select [lindex $tags 0] [lindex $tags 3]
  2256.         message "[lindex $tags 4] selected."
  2257.     } else {
  2258.         beep
  2259.         message "Cannot decide on enclosing tags."
  2260.     }
  2261. }
  2262.  
  2263. # Select an opening tag, or remove it, of an element without a closing tag.
  2264. proc htmlSelectOpening {remove} {
  2265.     set begin [getPos]
  2266.     # back up one if possible and selection is wanted.
  2267.     if {$begin >0 && !$remove} {incr begin -1}
  2268.     set tag [htmlGetOpening $begin]
  2269.     if {[llength $tag] == 3} {
  2270.         if {$remove} {
  2271.             deleteText [lindex $tag 0] [lindex $tag 1]
  2272.             if {$begin < [lindex $tag 1]} {set begin [lindex $tag 1]}
  2273.             goto [expr $begin - [lindex $tag 1] + [lindex $tag 0]]
  2274.             message "[lindex $tag 2] deleted."
  2275.         } else {
  2276.             select [lindex $tag 0] [lindex $tag 1]
  2277.             message "[lindex $tag 2] selected."
  2278.         }
  2279.     } else {
  2280.         if {$remove} {
  2281.             alertnote "Cannot find opening tag."
  2282.         } else {
  2283.             beep
  2284.             message "Cannot find opening tag."
  2285.         }
  2286.     }
  2287. }
  2288.  
  2289. # Change an existing element.
  2290. proc htmlChangeContainer {} {
  2291.     set tag [htmlGetContainer [getPos] [selEnd]]
  2292.     if {[llength $tag] == 5} {
  2293.         set newTag [htmlChangeElement [getText [expr [lindex $tag 0] + 1] ¥
  2294.         [expr [lindex $tag 1] - 1]] [lindex $tag 4]]
  2295.         if {[string length $newTag]} {
  2296.             replaceText [lindex $tag 0] [lindex $tag 1] $newTag
  2297.         }
  2298.     } else {
  2299.         alertnote "Cannot decide on enclosing tags."
  2300.     }
  2301. }
  2302.  
  2303. proc htmlChangeOpening {} {
  2304.     set tag [htmlGetOpening [getPos]]
  2305.     if {[llength $tag] == 3} {
  2306.         set newTag [htmlChangeElement [getText [expr [lindex $tag 0] + 1] ¥
  2307.         [expr [lindex $tag 1] - 1]] [lindex $tag 2]]
  2308.         if {[string length $newTag]} {
  2309.             replaceText [lindex $tag 0] [lindex $tag 1] $newTag
  2310.         }
  2311.     } else {
  2312.         alertnote "Cannot find opening tag."
  2313.     }
  2314. }
  2315.  
  2316. #
  2317. # Exstracts all attributes to a element from a list, and puts up a dialog window
  2318. # where the user can change the attributes.
  2319. #
  2320. proc htmlChangeElement {tag elem} {
  2321.     global htmlColorAttr htmlURLAttr HTMLmodeVars
  2322.     global htmluserColorname htmlColorNumber htmlPackageToUse
  2323.     global htmlElemAttrOptional1 htmlElemAttrOptional3
  2324.     global htmlElemEventHandler1 htmlWindowAttr htmlPlugins
  2325.     global htmlSpecURL htmlSpecColor htmlSpecWindow
  2326.  
  2327.     # Remove tabs and returns from list.
  2328.     regsub -all "¥[¥t¥r¥]+" $tag " " tag
  2329.     
  2330.     # Remove element name.
  2331.     set tagelem [lindex $tag 0]
  2332.     set tag [string range $tag [string length $tagelem] end]
  2333.     set attrs ""
  2334.     set attrVals ""
  2335.     
  2336.     # Exstract the attributes.
  2337.     while {[regexp {[ ]+([^ "]+"[^"]*"|[^ "]+)} $tag thisatt]} {
  2338.         set tag [string range $tag [string length $thisatt] end]
  2339.         set thisatt [htmlRemoveQuotes $thisatt]
  2340.         lappend attrs [string trim [lindex $thisatt 0]]
  2341.         lappend attrVals [lindex $thisatt 1]
  2342.     }    
  2343.     
  2344.     # All INPUT elements are defined differently. Must extract TYPE.
  2345.     if {$elem == "INPUT"} {
  2346.         set typeIndex [lsearch -exact [string toupper $attrs] "TYPE="]
  2347.         if {$typeIndex >= 0 } {
  2348.             set elem [string toupper [lindex $attrVals $typeIndex]]
  2349.             # Remove TYPE attribute from list.
  2350.             set attrs [lreplace $attrs $typeIndex $typeIndex]
  2351.             set attrVals [lreplace $attrVals $typeIndex $typeIndex]
  2352.             set used "INPUT TYPE=¥"${elem}¥""
  2353.         } else {
  2354.             beep 
  2355.             message "INPUT element without a TYPE attribute."
  2356.             return
  2357.         } 
  2358.     } else {
  2359.         set used $elem
  2360.     }
  2361.     
  2362.     # If EMBED element, choose which
  2363.     if {$elem == "EMBED" && $htmlPackageToUse == 1} {
  2364.         if {[catch {listpick -p "Which plug-in?" [lsort $htmlPlugins]} elem] || ![string length $elem]} {return}
  2365.     }
  2366.     
  2367.     # If LI element and Extensions package, check in which list.
  2368.     if {$elem == "LI"} {
  2369.         set listType ""
  2370.         foreach l [list UL OL DIR MENU] {
  2371.             set ex "<${l}(¥[ ¥¥t¥¥r¥]+¥[^>¥]*>|>)"
  2372.             set listOpening [search -s -f 0 -i 1 -r 1 -m 0 -n $ex [getPos]]
  2373.             set ex2 </$l>
  2374.             set listClosing [search -s -f 0 -i 1 -r 1 -m 0 -n $ex2 [getPos]]
  2375.             # Search until a single list opening is found.
  2376.             while {[string length $listOpening] && [string length $listClosing] &&
  2377.             [lindex $listClosing 0] > [lindex $listOpening 0]} {
  2378.                 set listOpening [search -s -f 0 -i 1 -r 1 -m 0 -n $ex [expr [lindex $listOpening 0] - 1]]
  2379.                 set listClosing [search -s -f 0 -i 1 -r 1 -m 0 -n $ex2 [expr [lindex $listClosing 0] - 1]]
  2380.             }
  2381.             if {[string length $listOpening]} {
  2382.                 lappend listType "$listOpening $l"
  2383.             }
  2384.         }
  2385.         set ltype [lindex [lindex $listType 0] 2]
  2386.         set lnum [lindex [lindex $listType 0] 0]
  2387.         for {set i 1} {$i < [llength $listType]} {incr i} {
  2388.             if {[lindex [lindex $listType $i] 0] > $lnum} {
  2389.                 set ltype [lindex [lindex $listType $i] 2]
  2390.                 set lnum [lindex [lindex $listType $i] 0]
  2391.             }
  2392.         }
  2393.         if {$ltype == "UL"} {
  2394.             set elem "LI IN UL"
  2395.         } elseif {$ltype == "OL"} {
  2396.             set elem "LI IN OL"
  2397.         }            
  2398.     }
  2399.     
  2400.     set eventText ""
  2401.     
  2402.     # JavaScript event handlers. Extension package only.
  2403.     if {$htmlPackageToUse == 1 && [info exists htmlElemEventHandler1($elem)]} {
  2404.         set eventHandler [string toupper $htmlElemEventHandler1($elem)]
  2405.     } else {
  2406.         set eventHandler ""
  2407.     }
  2408.     # Remove event handler from attributes list,
  2409.     # if they should not be included, and save them to put them back later.
  2410.     set attrsToupper [string toupper $attrs]
  2411.     if {!$HTMLmodeVars(inclEventHandler)} {
  2412.         foreach ev $eventHandler {
  2413.             set evIndex [lsearch -exact $attrsToupper $ev]
  2414.             if {$evIndex >=0} {
  2415.                 append eventText " " [lindex $attrs $evIndex] ¥
  2416.                 [htmlAddQuotes [lindex $attrVals $evIndex]]
  2417.                 set attrs [lreplace $attrs $evIndex $evIndex]
  2418.                 set attrVals [lreplace $attrVals $evIndex $evIndex]
  2419.                 set attrsToupper [lreplace $attrsToupper $evIndex $evIndex]
  2420.             }
  2421.         }
  2422.     }
  2423.     
  2424.     set attrs $attrsToupper
  2425.         
  2426.     # Element known by HTML mode?
  2427.     if {![info exists htmlElemAttrOptional${htmlPackageToUse}($elem)]} {
  2428.         alertnote "Unknown element: $elem"
  2429.         return
  2430.     }
  2431.     
  2432.     set allAttrs [concat [htmlGetRequired $elem] [htmlGetOptional $elem]]
  2433.     if {[string length $eventHandler]} {append allAttrs " " $eventHandler}
  2434.     
  2435.     set choices [htmlGetChoices $elem]
  2436.     set numAttrs [htmlGetNumber $elem]
  2437.     
  2438.     set errText ""
  2439.     
  2440.     # Check if there are some unknown attributes.
  2441.     foreach a $attrs {
  2442.         if {[lsearch -exact $allAttrs $a] < 0} {
  2443.             lappend errText "Unknown attribute: $a"
  2444.         }
  2445.     }
  2446.     
  2447.     # Does this element have any attributes?
  2448.     if {![llength $allAttrs]} {
  2449.         if {[llength $errText]} {
  2450.             if {[askyesno "$elem has no attributes. Remove the ones in the text?"] == "no"} {
  2451.                 return
  2452.             } else {
  2453.                 # Remove the error text to prevent another popup window.
  2454.                 set errText ""
  2455.             }
  2456.         } else {
  2457.             message "$elem has no attributes."
  2458.             return
  2459.         }
  2460.     } 
  2461.             
  2462.     # Add two dummy elements for OK and Cancel buttons.
  2463.     set values {0 0}
  2464.  
  2465.     # Build a list with attribute vales.
  2466.     foreach a $allAttrs {
  2467.         set attrIndex [lsearch -exact $attrs $a]
  2468.         if {$attrIndex >= 0 } {set aval [lindex $attrVals $attrIndex]}
  2469.         set a2 [string trimright $a =]
  2470.         if {([lsearch -exact $htmlURLAttr $a] >= 0 && [lsearch -exact $htmlSpecURL "${elem}!=$a2"] < 0) || ¥
  2471.         [lsearch -exact $htmlSpecURL "${elem}=$a2"] >= 0} {
  2472.             # URL
  2473.             if {$attrIndex >= 0} {
  2474.                 htmlAddToCache URLs $aval
  2475.                 lappend values "" $aval 0
  2476.             } else {
  2477.                 lappend values "" "No value" 0
  2478.             }
  2479.         } elseif {([lsearch -exact $htmlColorAttr $a] >= 0 && [lsearch -exact $htmlSpecColor "${elem}!=$a2"] < 0) || ¥
  2480.         [lsearch -exact $htmlSpecColor "${elem}=$a2"] >= 0} {
  2481.             # Color
  2482.             if {$attrIndex >= 0} {
  2483.                 set aval [htmlCheckColorNumber $aval]
  2484.                 if {$aval == 0} {
  2485.                     lappend errText "$a: Invalid color number."
  2486.                     lappend values "" "No value" 0
  2487.                 }
  2488.                 if {[info exists htmluserColorname($aval)]} {
  2489.                     lappend values "" $htmluserColorname($aval) 0
  2490.                 } elseif {[info exists htmlColorNumber($aval)]} {
  2491.                     lappend values "" $htmlColorNumber($aval) 0
  2492.                 } else {
  2493.                     lappend values $aval "No value" 0
  2494.                 }
  2495.             } else {
  2496.                 lappend values "" "No value" 0
  2497.             }
  2498.         } elseif {([lsearch -exact $htmlWindowAttr $a] >= 0 && [lsearch -exact $htmlSpecWindow "${elem}!=$a2"] < 0) || ¥
  2499.         [lsearch -exact $htmlSpecWindow "${elem}=$a2"] >= 0} {
  2500.             # Window
  2501.             if {$attrIndex >= 0} {
  2502.                 if {[lsearch -exact [list _SELF _TOP _PARENT _BLANK] [string toupper $aval]] < 0} {
  2503.                     htmlAddToCache windows $aval
  2504.                 } else {
  2505.                     set aval [string toupper $aval]
  2506.                 }
  2507.                 lappend values "" $aval
  2508.             } else {
  2509.                 lappend values "" "No value"
  2510.             }
  2511.         } elseif {[lsearch $numAttrs "${a}*"] >= 0} {
  2512.             # Number
  2513.             if {$attrIndex >= 0} {
  2514.                 set numcheck [htmlCheckAttrNumber $elem $a $aval]
  2515.                 if {$numcheck == 1} {
  2516.                     lappend values $aval
  2517.                 } else {
  2518.                     lappend errText "$a: $numcheck"
  2519.                     lappend values ""
  2520.                 }
  2521.             } else {
  2522.                 lappend values ""
  2523.             }
  2524.         } elseif {[string match "*${a}*" $choices] && [string index $a [expr [string length $a] - 1]] == "="} {
  2525.             # Choices
  2526.             if {$attrIndex >= 0} {
  2527.                 set match ""
  2528.                 if {!(($elem == "OL" || $elem == "LI IN OL") && $a == "TYPE=")} {
  2529.                     set aval [string toupper $aval]
  2530.                 }
  2531.                 foreach w $choices {
  2532.                     if {$w == "${a}${aval}"} {
  2533.                         set match $aval
  2534.                     }
  2535.                 }
  2536.                 if {[string length $match]} {
  2537.                     lappend values $match
  2538.                 } else {
  2539.                     lappend errText "$a: Unknown choice, $aval."
  2540.                     lappend values "No value"
  2541.                 }
  2542.             } else {
  2543.                 lappend values "No value"
  2544.             }    
  2545.         } elseif {[string index $a [expr [string length $a] - 1]] == "="} {
  2546.             # Any other
  2547.             if {$attrIndex >= 0} {
  2548.                 lappend values $aval
  2549.             } else {
  2550.                 lappend values ""
  2551.             }
  2552.         } elseif {$attrIndex >= 0} {
  2553.             # Flag
  2554.             lappend values 1
  2555.         } else {
  2556.             lappend values 0
  2557.         }
  2558.     }
  2559.     # If invalid attributes, continue?
  2560.     if {[llength $errText] && ![htmlErrorWindow "$elem not well-defined" $errText 1]} {
  2561.         return 
  2562.     }
  2563.     
  2564.     set r [htmlOpenElemWindow $used $elem $values]
  2565.     # Put back event handlers. Empty string means "Cancel", do nothing.
  2566.     if {[string length $r]} {
  2567.         set r "[string range $r 0 [expr [string length $r] - 2]]$eventText>"
  2568.     }
  2569.     return $r
  2570. }
  2571.  
  2572. # Splits an attribute into its name and value and remove quotes.
  2573. proc htmlRemoveQuotes {attrStr} {
  2574.     # Is it a flag?
  2575.     if {![string match "*=*" $attrStr]} {return [string toupper $attrStr]}
  2576.     
  2577.     set attr [string range $attrStr 0 [string first "=" $attrStr]]
  2578.     # Get the attribute value.
  2579.     set attrVal [string range $attrStr [expr [string first "=" $attrStr] + 1] end]
  2580.     
  2581.     return [list $attr [string trim $attrVal ¥"]]
  2582. }
  2583.  
  2584.     
  2585. #
  2586. # launch a viewer and pass this window to it
  2587. #
  2588.  
  2589. proc htmlSendWindow {{path ""}} {
  2590.     global HTMLmodeVars browserSig
  2591.  
  2592.     if {[catch {launchBackApplSigs {MOSS } browserSig}]} {
  2593.         getApplSig "Please locate your web browser" browserSig
  2594.     }
  2595.     set name [file tail [launchBackAppl $browserSig]]
  2596.  
  2597.     if {$path == ""} {
  2598.         set path [stripNameCount [car [winNames -f]]]
  2599.  
  2600.         if {[winDirty]} {
  2601.             case [askyesno -c "Save '[file tail $path]'?"] in {
  2602.                 "yes" {save}
  2603.                 "no" {}
  2604.                 "cancel" {return}
  2605.             }
  2606.         }
  2607.     }
  2608.     
  2609.     sendOpenEvent -n $name $path
  2610.      if {$HTMLmodeVars(browseInForeground)} { switchTo $name }
  2611. }
  2612.  
  2613.  
  2614. proc htmlCleanUpCache {cache} {
  2615.     global HTMLmodeVars 
  2616.     global modifiedModeVars
  2617.     set URLs $HTMLmodeVars($cache)
  2618.  
  2619.     if {![llength $URLs]} {
  2620.         alertnote "No $cache are cached."
  2621.         return 1
  2622.     }
  2623.     set urlnumber [llength $URLs]
  2624.     set screenHeight [lindex [getMainDevice] 3]
  2625.     set maxLines [expr ($screenHeight - 160) / 20]
  2626.     set pages [expr ($urlnumber - 1) / $maxLines ]
  2627.     set thispage 0
  2628.     set finished 0
  2629.     set canceled 0
  2630.     set checked 1
  2631.     while {!$finished} {
  2632.         if {$thispage < $pages} {
  2633.             set thisurlnumber $maxLines
  2634.         } else {
  2635.             set thisurlnumber [expr ($urlnumber - 1 ) % $maxLines + 1]
  2636.         }
  2637.         set height [expr 75 + $thisurlnumber  * 20]
  2638.         set box "-w 440 -h $height -b OK 20 [expr $height - 30]  85 [expr $height - 10] ¥
  2639.             -b Cancel 110 [expr $height - 30] 175 [expr $height - 10] ¥
  2640.             -b {Uncheck all} 200 [expr $height - 30] 285 [expr $height - 10] ¥
  2641.             -t {Uncheck the $cache you want to remove} 10 10 440 30 "
  2642.  
  2643.         set hpos 30 
  2644.         set thisURLs [lrange $URLs [expr $thispage * $maxLines] ¥
  2645.         [expr $thispage * $maxLines + $maxLines - 1]]
  2646.         foreach url $thisURLs {
  2647.             lappend box -c $url $checked 10 $hpos 390 [expr $hpos + 15]
  2648.             incr hpos 20
  2649.         }
  2650.         if {$thispage < $pages} {
  2651.             lappend box -b "Moreﾉ" 310 [expr $height - 30] 375 [expr $height - 10]
  2652.         }
  2653.         set thisbox [eval [concat dialog $box]]
  2654.         if {[lindex $thisbox 1]} { # cancel
  2655.             set finished 1
  2656.             set canceled 1
  2657.         } elseif {[lindex $thisbox 2]} {
  2658.             set checked 0
  2659.         } else {
  2660.             if {$thispage == $pages} {
  2661.                 set ll 1
  2662.             } else {
  2663.                 set ll 2
  2664.             }
  2665.             append URLsToSave " " [lrange $thisbox 3 [expr [llength $thisbox] - $ll]]
  2666.             if {[lindex $thisbox 0]} { # OK
  2667.                 set finished 1
  2668.             } else { # more
  2669.                 set thispage [expr $thispage + 1]
  2670.                 set checked 1
  2671.             }
  2672.         }
  2673.     }
  2674.     set newurls ""
  2675.     if {!$canceled} {
  2676.         set saveurlnumber [llength $URLsToSave]
  2677.         for {set i 0} {$i < $saveurlnumber} {incr i} {
  2678.             if {[lindex $URLsToSave $i]} {
  2679.                 lappend newurls [lindex $URLs $i]
  2680.             }
  2681.         }
  2682.         if {$saveurlnumber < $urlnumber} {
  2683.             append newurls " " [lrange $URLs $saveurlnumber end]
  2684.         }
  2685.         set URLs $newurls
  2686.         set HTMLmodeVars($cache) $URLs
  2687.         lappend modifiedModeVars [list $cache HTMLmodeVars]
  2688.     }
  2689. }
  2690.  
  2691. proc htmlSelToURL {} {
  2692.  
  2693.     set newurl [string trim [getSelect]]
  2694.     # Don't add if there are spaces, tabs or returns.
  2695.     if {[regexp {[ ¥t¥r]+} $newurl]} {
  2696.         alertnote "Selection contains spaces. It will not be added to URL cache."
  2697.         return
  2698.     }
  2699.     if {[string length $newurl]} {
  2700.         htmlAddToCache URLs $newurl
  2701.         message "$newurl added to URLs."
  2702.     } else {
  2703.         beep
  2704.         message "No selection!"
  2705.     }
  2706. }
  2707.  
  2708. proc htmlScrapToURL {} {
  2709.  
  2710.     set newurl [string trim [getScrap]]
  2711.     # Don't add if there are spaces, tabs or returns.
  2712.     if {[regexp {[ ¥t¥r]+} $newurl]} {
  2713.         alertnote "Clipboard contains spaces. It will not be added to URL cache."
  2714.         return
  2715.     }
  2716.     if {[string length $newurl]} {
  2717.         htmlAddToCache URLs $newurl
  2718.         message "$newurl added to URLs."
  2719.     } else {
  2720.         beep
  2721.         message "Clipboard empty!"
  2722.     }
  2723. }
  2724.  
  2725. proc htmlClearCache {cache} {
  2726.     global HTMLmodeVars modifiedModeVars
  2727.     if {[askyesno "Remove all $cache from [string range $cache 0 [expr [string length $cache] - 2]] cache?"] == "yes"} {
  2728.         set HTMLmodeVars($cache) {}
  2729.         lappend modifiedModeVars [list $cache HTMLmodeVars]
  2730.     }
  2731. }
  2732.  
  2733. #==============================================================================
  2734. #
  2735. #    Colors
  2736. #
  2737. #==============================================================================
  2738.  
  2739. # Convert colour names to numbers and vice versa.
  2740. # Colour name or number must be quoted for this to work.
  2741. proc htmlRevealColor {} {
  2742.     global htmlColorName htmlColorNumber htmlColorAttr htmluserColors 
  2743.     global htmluserColorname
  2744.  
  2745.     set searchstring "("
  2746.     foreach s $htmlColorAttr {
  2747.         append searchstring "${s}|"
  2748.     } 
  2749.     # remove last |
  2750.     set searchstring [string trimright $searchstring |]
  2751.     append searchstring ")((¥[^ ¥¥t¥¥r¥">¥]+)|¥"(¥[^¥"¥]+)¥")"
  2752.     set startpos [getPos]
  2753.     set endpos [selEnd]
  2754.     set cantfind 0
  2755.     # find attribute
  2756.     set f [search -s -f 0 -r 1 -i 1 -n -m 0 $searchstring $startpos]
  2757.     if {![string length $f] || [lindex $f 1] < $endpos} {
  2758.         set cantfind 1
  2759.     }
  2760.     if {!$cantfind} {
  2761.         set txt [getText [lindex $f 0] [lindex $f 1]]
  2762.         regexp -indices -nocase $searchstring $txt a b c
  2763.         set cpos [expr [lindex $f 0] + [lindex $c 0]]
  2764.         set epos [expr [lindex $f 0] + [lindex $c 1] + 1]
  2765.         set col [string trim [string range $txt [lindex $c 0] [lindex $c 1]] ¥"]
  2766.         if {[info exists htmlColorName($col)]} {
  2767.             replaceText $cpos $epos "¥"$htmlColorName($col)¥""
  2768.         } elseif {[info exists htmlColorNumber($col)]} {
  2769.             replaceText $cpos $epos "¥"$htmlColorNumber($col)¥""
  2770.         } elseif {[info exists htmluserColorname($col)]} {
  2771.             replaceText $cpos $epos "¥"$htmluserColorname($col)¥""
  2772.         } elseif {[info exists htmluserColors($col)]} {
  2773.             replaceText $cpos $epos "¥"$htmluserColors($col)¥""
  2774.         } else {
  2775.             beep
  2776.             message "Don't recognize color."
  2777.         }
  2778.     } else {
  2779.         beep
  2780.         message "Current position is not at a color attribute."
  2781.     }
  2782. }
  2783.  
  2784. # Prompt a for a new color. Returns the color name. If cancel, returns ""
  2785.  
  2786. proc htmlAddNewColor {} {
  2787.     global htmluserColors htmluserColorname basicColors htmlColorNumber
  2788.     
  2789.     set alluserColors [array names htmluserColors]
  2790.     set hexa {A B C D E F}
  2791.     
  2792.     set newcolor [colorTriple "New color"]
  2793.     
  2794.     if {![string length $newcolor]} {return }
  2795.  
  2796.     set red [expr [lindex $newcolor 0] / 256]
  2797.     set green [expr [lindex $newcolor 1] / 256]
  2798.     set blue [expr [lindex $newcolor 2] / 256]
  2799.     set red1 [expr $red / 16]
  2800.     set red2 [expr $red % 16]
  2801.     set green1 [expr $green / 16]
  2802.     set green2 [expr $green % 16]
  2803.     set blue1 [expr $blue / 16]
  2804.     set blue2 [expr $blue % 16]
  2805.     set colornumber {#}
  2806.     foreach c [list $red1 $red2 $green1 $green2 $blue1 $blue2] {
  2807.         if {$c > 9} {
  2808.             set c1 [lindex $hexa [expr $c - 10]]
  2809.         } else {
  2810.             set c1 $c
  2811.         }
  2812.         append colornumber $c1
  2813.     }
  2814.  
  2815.     # See if the colour already exists.
  2816.     if {![catch {set colTest $htmlColorNumber($colornumber)}] || ¥
  2817.     ![catch {set colTest $htmluserColorname($colornumber)}]} {
  2818.         alertnote "This color is identical with '$colTest'. Two identical ¥
  2819.         colors cannot be defined."
  2820.         return
  2821.     }
  2822.     
  2823.     set noname 1
  2824.     while {$noname} {
  2825.         if {[catch {prompt "Color name" ""} colorname]} { # cancel
  2826.             set noname 0
  2827.             return
  2828.         } else {
  2829.             set colorname [string trim $colorname]
  2830.             if {[lsearch -exact $basicColors $colorname] >= 0} {
  2831.                 alertnote "Predefined color. Choose another name."
  2832.             } elseif {[string length $colorname]} {
  2833.                 set replace 0
  2834.                 if {[lsearch -exact $alluserColors $colorname] >= 0 } {
  2835.                     set repl [dialog -w 200 -h 75 -b Cancel 20 40 80 60 ¥
  2836.                         -b Replace 115 40 175 60 ¥
  2837.                         -t "Replace $colorname?" 10 10 150 30]
  2838.                     if {[lindex $repl 1] } { 
  2839.                         set replace 1
  2840.                         # remove the color first 
  2841.                         set oldnumber $htmluserColors($colorname)
  2842.                         htmlColordelete $colorname $oldnumber
  2843.                     }
  2844.                 } else {
  2845.                     set replace 1
  2846.                 }
  2847.                 if {$replace} { # add the new color
  2848.                     set noname 0
  2849.                     htmlColordef $colorname $colornumber
  2850.                     message "Color saved!"
  2851.                 }
  2852.             } else {
  2853.                 alertnote "You must name the color."
  2854.             }
  2855.         }
  2856.     }
  2857.     return $colorname
  2858. }
  2859.  
  2860. proc htmlChangeColor {} {
  2861.     global htmluserColors htmluserColorname basicColors htmlColorNumber
  2862.         
  2863.     set hexa {A B C D E F}
  2864.     set colors [lsort [array names htmluserColors]]
  2865.     
  2866.     if {![string length $colors]} {
  2867.         alertnote "No colors are defined."
  2868.         return 
  2869.     }
  2870.     if {[catch {listpick -p "Select the color to change" $colors} changeColor] || ¥
  2871.     ![string length $changeColor]} {return}
  2872.     
  2873.     # Calculate the red green and blue numbers.
  2874.     set colornumber $htmluserColors($changeColor)
  2875.     set red1 [string range $colornumber 1 1]
  2876.     set red2 [string range $colornumber 2 2]
  2877.     set green1 [string range $colornumber 3 3]
  2878.     set green2 [string range $colornumber 4 4]
  2879.     set blue1 [string range $colornumber 5 5]
  2880.     set blue2 [string range $colornumber 6 6]
  2881.     foreach c [list $red1 $red2 $green1 $green2 $blue1 $blue2] {
  2882.         switch $c {
  2883.             A    {set c1 10}
  2884.             B    {set c1 11}
  2885.             C    {set c1 12}
  2886.             D    {set c1 13}
  2887.             E    {set c1 14}
  2888.             F    {set c1 15}
  2889.             default {set c1 $c}
  2890.         }
  2891.         lappend numbers $c1
  2892.     }
  2893.     set red [expr [lindex $numbers 0] * 4096 + [lindex $numbers 1] * 256]
  2894.     set green [expr [lindex $numbers 2] * 4096 + [lindex $numbers 3] * 256]
  2895.     set blue [expr [lindex $numbers 4] * 4096 + [lindex $numbers 5] * 256]
  2896.     
  2897.     # Get a new colour.
  2898.     set newcolor [colorTriple $changeColor $red $green $blue]
  2899.     if {![string length newcolor]} {return}
  2900.     
  2901.     set red [expr [lindex $newcolor 0] / 256]
  2902.     set green [expr [lindex $newcolor 1] / 256]
  2903.     set blue [expr [lindex $newcolor 2] / 256]
  2904.     set red1 [expr $red / 16]
  2905.     set red2 [expr $red % 16]
  2906.     set green1 [expr $green / 16]
  2907.     set green2 [expr $green % 16]
  2908.     set blue1 [expr $blue / 16]
  2909.     set blue2 [expr $blue % 16]
  2910.     set newnumber {#}
  2911.     foreach c [list $red1 $red2 $green1 $green2 $blue1 $blue2] {
  2912.         if {$c > 9} {
  2913.             set c1 [lindex $hexa [expr $c - 10]]
  2914.         } else {
  2915.             set c1 $c
  2916.         }
  2917.         append newnumber $c1
  2918.     }
  2919.     # See if the colour already exists.
  2920.     if {( ![catch {set colTest $htmlColorNumber($newnumber)}] || ¥
  2921.     ![catch {set colTest $htmluserColorname($newnumber)}] ) && ¥
  2922.     $colTest != $changeColor} {
  2923.         alertnote "This color is identical with '$colTest'. Two identical ¥
  2924.         colors cannot be defined."
  2925.         return
  2926.     }
  2927.     set noname 1
  2928.     # Choose a new name for the colour.
  2929.     while {$noname} {
  2930.         if {[catch {prompt "Color name" $changeColor} colorname]} {
  2931.             set noname 0
  2932.         } else {
  2933.             set colorname [string trim $colorname]
  2934.             if {[lsearch -exact $basicColors $colorname] >= 0} {
  2935.                 alertnote "Predefined color. Choose another name."
  2936.             } elseif {[string length $colorname]} {
  2937.                 set replace 0
  2938.                 if {[lsearch -exact $colors $colorname] >= 0 &&
  2939.                 $colorname != $changeColor} {
  2940.                     set repl [dialog -w 200 -h 75 -b Cancel 20 40 80 60 ¥
  2941.                     -b Replace 115 40 175 60 ¥
  2942.                     -t "Replace $colorname?" 10 10 150 30]
  2943.                     if {[lindex $repl 1] } { 
  2944.                         set replace 1
  2945.                         # remove the color first 
  2946.                         set oldnumber $htmluserColors($colorname)
  2947.                         htmlColordelete $colorname $oldnumber
  2948.                     }
  2949.                 } else {
  2950.                     set replace 1
  2951.                 }
  2952.                 
  2953.                 if {$replace} { 
  2954.                     # remove the old colour
  2955.                     htmlColordelete $changeColor $colornumber
  2956.                     set noname 0
  2957.                     # add the new colour
  2958.                     htmlColordef $colorname $newnumber
  2959.                     message "Color changed."
  2960.                 }
  2961.             } else {
  2962.                 alertnote "You must name the color."
  2963.             }
  2964.         }
  2965.     }
  2966. }
  2967.  
  2968.  
  2969. proc htmlRemoveColors {} {
  2970.     global htmluserColors htmluserColorname
  2971.  
  2972.     set colors [lsort [array names htmluserColors]]
  2973.     
  2974.     if {![string length $colors]} {
  2975.         alertnote "No colors are defined."
  2976.         return 
  2977.     }
  2978.     if {![catch {listpick -l -p "Select the colors to remove" $colors} removeColors] && ¥
  2979.     [string length $removeColors]} {
  2980.         foreach c $removeColors {
  2981.             set colornumber $htmluserColors($c)
  2982.             htmlColordelete $c $colornumber
  2983.         }
  2984.         message "Colors removed."
  2985.     }
  2986. }
  2987.  
  2988. proc htmlColordef {colorname colornumber} {
  2989.     global htmluserColors htmluserColorname
  2990.     
  2991.     set htmluserColors($colorname) $colornumber
  2992.     set htmluserColorname($colornumber) $colorname
  2993.     addArrDef htmluserColors $colorname $colornumber
  2994.     addArrDef htmluserColorname $colornumber $colorname
  2995. }
  2996.  
  2997. proc htmlColordelete {colorname colornumber} {
  2998.     global htmluserColors htmluserColorname
  2999.     
  3000.     catch {unset htmluserColors($colorname)}
  3001.     catch {unset htmluserColorname($colornumber)}
  3002.     removeArrDef htmluserColors $colorname
  3003.     removeArrDef htmluserColorname $colornumber
  3004. }
  3005.  
  3006.  
  3007. # Set the home page URL
  3008. proc htmlServerURL {} {
  3009.     global modifiedModeVars HTMLmodeVars
  3010.     
  3011.     set baseURL $HTMLmodeVars(baseURL)
  3012.     set basePath  $HTMLmodeVars(basePath)
  3013.     set val [dialog -w 450 -h 110 -t "Server URL:" 10 10 90 30 ¥
  3014.     -e $baseURL 100 10 440 25 -t "Path:" 50 45 90 55 ¥
  3015.     -e $basePath 100 45 440 60 -b OK 20 80 85 100 -b Cancel 110 80 175 100]
  3016.     
  3017.     if {[lindex $val 2]} {
  3018.         # Add / at the end if necessary.
  3019.         set baseURL [string trim [lindex $val 0]]
  3020.         set basePath [string trim [lindex $val 1]]
  3021.         if {[string length $baseURL] && ¥
  3022.         [string range $baseURL [expr [string length $baseURL] - 1] end] != "/"} {
  3023.             append baseURL "/"
  3024.         }
  3025.         if {[string length $basePath]} {
  3026.             if {[string range $basePath [expr [string length $basePath] - 1] end] != "/"} {
  3027.                 append basePath "/"
  3028.             }
  3029.             # Remove / from beginning of path.
  3030.             set basePath [string trimleft $basePath /]
  3031.         }
  3032.         set HTMLmodeVars(basePath) $basePath
  3033.         set HTMLmodeVars(baseURL) $baseURL
  3034.         lappend modifiedModeVars {baseURL HTMLmodeVars} {basePath HTMLmodeVars}
  3035.     }
  3036. }
  3037.  
  3038. # Define a file as a footer.
  3039. proc htmlFooter {} {
  3040.     global HTMLmodeVars modifiedModeVars
  3041.     
  3042.     set footers $HTMLmodeVars(footers)
  3043.     if {![catch {getfile "Select the file with the footer."} newFooter]} {
  3044.         getFileInfo $newFooter filetest
  3045.         if {$filetest(type) != "TEXT"} {
  3046.             alertnote "'[file tail $newFooter]' is not a text file."
  3047.             return
  3048.         } elseif {[lsearch -exact $footers $newFooter] < 0} {
  3049.             # Can't define two footers with the same file name.
  3050.             foreach f $footers {
  3051.                 if {[file tail $f] == [file tail $newFooter]} {
  3052.                     alertnote "There is already a footer with the filename¥
  3053.                     '[file tail $newFooter]'. Two footers with the same filename¥
  3054.                     cannot be defined."
  3055.                     return
  3056.                 }
  3057.             }
  3058.             lappend footers $newFooter
  3059.             set HTMLmodeVars(footers) $footers
  3060.             lappend modifiedModeVars {footers HTMLmodeVars}
  3061.         } else {
  3062.             alertnote "$newFooter already a footer."
  3063.             return
  3064.         }
  3065.         message "[file tail $newFooter] is now a footer."
  3066.     }
  3067. }
  3068.  
  3069. # Remove footers from list.
  3070. proc htmlRemoveFooter {} {
  3071.     global HTMLmodeVars modifiedModeVars
  3072.     
  3073.     set footers $HTMLmodeVars(footers)
  3074.     
  3075.     if {![llength $footers]} {
  3076.         alertnote "No footers are defined."
  3077.         return
  3078.     }
  3079.     foreach f $footers {
  3080.         lappend foot [file tail $f]
  3081.     }
  3082.     
  3083.     if {![catch {listpick -l -p "Select the footers to remove" $foot} newFooters] && ¥
  3084.     [string length $newFooters]} {
  3085.         set newFoot ""
  3086.         foreach f $foot {
  3087.             if {[lsearch -exact $newFooters $f] < 0} {
  3088.                 lappend newFoot [lindex $footers [lsearch -exact $foot $f]]
  3089.             }
  3090.         }
  3091.         set HTMLmodeVars(footers) $newFoot
  3092.         lappend modifiedModeVars {footers HTMLmodeVars}
  3093.         message "Footers removed."
  3094.     }
  3095. }
  3096.  
  3097. # Insert a footer in the document
  3098. proc htmlInsertFooter {} {
  3099.     global HTMLmodeVars
  3100.     
  3101.     set footers $HTMLmodeVars(footers)
  3102.     if {![llength $footers]} {
  3103.         alertnote "No footers are defined."
  3104.         return
  3105.     }
  3106.     foreach f $footers {
  3107.         lappend foot [file tail $f]
  3108.     }
  3109.     
  3110.     if {![catch {listpick -p "Select the footer to insert" $foot} footval] && ¥
  3111.     [string length $footval]} {
  3112.         set footerFile [lindex $footers [lsearch -exact $foot $footval]]
  3113.         if {![catch {readFile $footerFile} footText]} {
  3114.             insertText "¥r$footText¥r"
  3115.         } else {
  3116.             alertnote "Could not read $footerFile"
  3117.             return
  3118.         }
  3119.         message "[file tail $footerFile] inserted."
  3120.     }
  3121. }
  3122.